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,
|
||||
InitialTypes,
|
||||
Interfaces,
|
||||
Lookup,
|
||||
Managed,
|
||||
Map,
|
||||
Meta,
|
||||
|
@ -209,7 +209,7 @@ cTypeToCarpType ("long", 0) = LongTy
|
||||
cTypeToCarpType ("double", 0) = DoubleTy
|
||||
cTypeToCarpType ("float", 0) = FloatTy
|
||||
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)))
|
||||
|
||||
identifierChar :: Parsec.Parsec String () Char
|
||||
|
@ -10,6 +10,12 @@ import ToTemplate
|
||||
import Types
|
||||
import TypesToC
|
||||
|
||||
arrayTyA :: Ty
|
||||
arrayTyA = StructTy (ConcreteNameTy (SymPath [] "Array")) [(VarTy "a")]
|
||||
|
||||
arrayRef :: Ty
|
||||
arrayRef = RefTy arrayTyA (VarTy "q")
|
||||
|
||||
-- | "Endofunctor Map"
|
||||
templateEMap :: (String, Binder)
|
||||
templateEMap =
|
||||
@ -20,9 +26,8 @@ templateEMap =
|
||||
documentation
|
||||
where
|
||||
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")
|
||||
arrayTy = StructTy (ConcreteNameTy "Array") [VarTy "a"]
|
||||
documentation =
|
||||
"applies a function `f` to an array `a`. The type of the elements cannot change."
|
||||
creatorFunc :: TypeEnv -> Env -> Template
|
||||
@ -30,7 +35,7 @@ templateEMap =
|
||||
Template
|
||||
templateType
|
||||
(templateLiteral "Array $NAME(Lambda *f, Array a)")
|
||||
( \(FuncTy [_, StructTy (ConcreteNameTy "Array") [memberTy]] _ _) ->
|
||||
( \(FuncTy [_, StructTy (ConcreteNameTy (SymPath [] "Array")) [memberTy]] _ _) ->
|
||||
handleUnits memberTy
|
||||
)
|
||||
( \(FuncTy [RefTy t@(FuncTy fArgTys fRetTy _) _, _] _ _) ->
|
||||
@ -64,9 +69,8 @@ templateEFilter :: (String, Binder)
|
||||
templateEFilter = defineTypeParameterizedTemplate templateCreator path t docs
|
||||
where
|
||||
fTy = FuncTy [RefTy (VarTy "a") (VarTy "q")] BoolTy (VarTy "fq")
|
||||
aTy = StructTy (ConcreteNameTy "Array") [VarTy "a"]
|
||||
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."
|
||||
elt = "&((($a*)a.data)[i])"
|
||||
declaration :: String -> (String -> String) -> [Token]
|
||||
@ -108,9 +112,8 @@ templatePushBack =
|
||||
defineTypeParameterizedTemplate creator path t docs
|
||||
where
|
||||
path = SymPath ["Array"] "push-back"
|
||||
aTy = StructTy (ConcreteNameTy "Array") [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`."
|
||||
declaration :: String -> [Token]
|
||||
declaration setter =
|
||||
@ -146,9 +149,8 @@ templatePushBackBang =
|
||||
defineTypeParameterizedTemplate creator path t docs
|
||||
where
|
||||
path = SymPath ["Array"] "push-back!"
|
||||
aTy = RefTy (StructTy (ConcreteNameTy "Array") [VarTy "a"]) (VarTy "q")
|
||||
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."
|
||||
declaration :: String -> [Token]
|
||||
declaration setter =
|
||||
@ -182,8 +184,7 @@ templatePopBack :: (String, Binder)
|
||||
templatePopBack = defineTypeParameterizedTemplate templateCreator path t docs
|
||||
where
|
||||
path = SymPath ["Array"] "pop-back"
|
||||
aTy = StructTy (ConcreteNameTy "Array") [VarTy "a"]
|
||||
t = FuncTy [aTy] aTy StaticLifetimeTy
|
||||
t = FuncTy [arrayTyA] arrayTyA StaticLifetimeTy
|
||||
docs = "removes the last element of an array and returns the new array."
|
||||
templateCreator = TemplateCreator $
|
||||
\typeEnv env ->
|
||||
@ -214,8 +215,7 @@ templatePopBackBang =
|
||||
defineTypeParameterizedTemplate creator path t docs
|
||||
where
|
||||
path = SymPath ["Array"] "pop-back!"
|
||||
aTy = RefTy (StructTy (ConcreteNameTy "Array") [VarTy "a"]) (VarTy "q")
|
||||
t = FuncTy [aTy] (VarTy "a") StaticLifetimeTy
|
||||
t = FuncTy [arrayRef] (VarTy "a") StaticLifetimeTy
|
||||
docs = "removes an element `value` from the end of an array `a` in-place and returns it."
|
||||
creator =
|
||||
TemplateCreator $
|
||||
@ -250,7 +250,7 @@ templateNth =
|
||||
let t = VarTy "t"
|
||||
in defineTemplate
|
||||
(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`."
|
||||
(toTemplate "$t* $NAME (Array *aRef, int n)")
|
||||
( toTemplate $
|
||||
@ -271,7 +271,7 @@ templateRaw :: (String, Binder)
|
||||
templateRaw =
|
||||
defineTemplate
|
||||
(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."
|
||||
(toTemplate "$t* $NAME (Array a)")
|
||||
(toTemplate "$DECL { return a.data; }")
|
||||
@ -281,7 +281,8 @@ templateUnsafeRaw :: (String, Binder)
|
||||
templateUnsafeRaw =
|
||||
defineTemplate
|
||||
(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."
|
||||
(toTemplate "$t* $NAME (Array* a)")
|
||||
(toTemplate "$DECL { return a->data; }")
|
||||
@ -301,7 +302,7 @@ templateAset :: (String, Binder)
|
||||
templateAset = defineTypeParameterizedTemplate templateCreator path t docs
|
||||
where
|
||||
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."
|
||||
templateCreator = TemplateCreator $
|
||||
\typeEnv env ->
|
||||
@ -336,7 +337,7 @@ templateAsetBang :: (String, Binder)
|
||||
templateAsetBang = defineTypeParameterizedTemplate templateCreator path t docs
|
||||
where
|
||||
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."
|
||||
templateCreator = TemplateCreator $
|
||||
\typeEnv env ->
|
||||
@ -372,7 +373,7 @@ templateAsetUninitializedBang :: (String, Binder)
|
||||
templateAsetUninitializedBang = defineTypeParameterizedTemplate templateCreator path t docs
|
||||
where
|
||||
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."
|
||||
templateCreator = TemplateCreator $
|
||||
\_ _ ->
|
||||
@ -402,7 +403,7 @@ templateLength :: (String, Binder)
|
||||
templateLength = defineTypeParameterizedTemplate templateCreator path t docs
|
||||
where
|
||||
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."
|
||||
templateCreator = TemplateCreator $
|
||||
\typeEnv env ->
|
||||
@ -418,7 +419,7 @@ templateAllocate :: (String, Binder)
|
||||
templateAllocate = defineTypeParameterizedTemplate templateCreator path t docs
|
||||
where
|
||||
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)."
|
||||
templateCreator = TemplateCreator $
|
||||
\typeEnv env ->
|
||||
@ -448,7 +449,7 @@ templateDeleteArray :: (String, Binder)
|
||||
templateDeleteArray = defineTypeParameterizedTemplate templateCreator path t docs
|
||||
where
|
||||
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."
|
||||
templateCreator = TemplateCreator $
|
||||
\typeEnv env ->
|
||||
@ -460,7 +461,7 @@ templateDeleteArray = defineTypeParameterizedTemplate templateCreator path t doc
|
||||
++ deleteTy typeEnv env arrayType
|
||||
++ [TokC "}\n"]
|
||||
)
|
||||
( \(FuncTy [StructTy (ConcreteNameTy "Array") [insideType]] UnitTy _) ->
|
||||
( \(FuncTy [StructTy (ConcreteNameTy (SymPath [] "Array")) [insideType]] UnitTy _) ->
|
||||
depsForDeleteFunc typeEnv env insideType
|
||||
)
|
||||
|
||||
@ -474,7 +475,7 @@ deleteTy typeEnv env (StructTy _ [innerType]) =
|
||||
deleteTy _ _ _ = []
|
||||
|
||||
initTy :: Ty -> [String]
|
||||
initTy (StructTy (ConcreteNameTy "Array") [innerType@FuncTy {}]) =
|
||||
initTy (StructTy (ConcreteNameTy (SymPath [] "Array")) [innerType@FuncTy {}]) =
|
||||
[ " // initialize each Lambda struct ",
|
||||
" for(int i = 0; i < a.len; i++) {",
|
||||
" " ++ insideArrayInitLambda innerType "i",
|
||||
@ -510,7 +511,7 @@ templateCopyArray :: (String, Binder)
|
||||
templateCopyArray = defineTypeParameterizedTemplate templateCreator path t docs
|
||||
where
|
||||
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."
|
||||
templateCreator = TemplateCreator $
|
||||
\typeEnv env ->
|
||||
@ -528,7 +529,7 @@ templateCopyArray = defineTypeParameterizedTemplate templateCreator path t docs
|
||||
++ [TokC "}\n"]
|
||||
)
|
||||
( \case
|
||||
(FuncTy [RefTy arrayType@(StructTy (ConcreteNameTy "Array") [insideType]) _] _ _) ->
|
||||
(FuncTy [RefTy arrayType@(StructTy (ConcreteNameTy (SymPath [] "Array")) [insideType]) _] _ _) ->
|
||||
depsForCopyFunc typeEnv env insideType
|
||||
++ depsForDeleteFunc typeEnv env arrayType
|
||||
err ->
|
||||
@ -536,7 +537,7 @@ templateCopyArray = defineTypeParameterizedTemplate templateCreator path t docs
|
||||
)
|
||||
|
||||
copyTy :: TypeEnv -> Env -> Ty -> [Token]
|
||||
copyTy typeEnv env (StructTy (ConcreteNameTy "Array") [innerType]) =
|
||||
copyTy typeEnv env (StructTy (ConcreteNameTy (SymPath [] "Array")) [innerType]) =
|
||||
if managed
|
||||
then
|
||||
[ TokC " for(int i = 0; i < a->len; i++) {\n",
|
||||
@ -580,11 +581,11 @@ templateStrArray = defineTypeParameterizedTemplate templateCreator path t docs
|
||||
++ strTy typeEnv env arrayType
|
||||
++ [TokC "}\n"]
|
||||
)
|
||||
( \(FuncTy [RefTy (StructTy (ConcreteNameTy "Array") [insideType]) _] StringTy _) ->
|
||||
( \(FuncTy [RefTy (StructTy (ConcreteNameTy (SymPath [] "Array")) [insideType]) _] StringTy _) ->
|
||||
depsForPrnFunc typeEnv env insideType
|
||||
)
|
||||
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."
|
||||
|
||||
-- | TODO: move this into the templateStrArray function?
|
||||
|
@ -49,7 +49,7 @@ assignTypes mappings root = visit root
|
||||
Nothing -> pure xobj
|
||||
|
||||
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
|
||||
|
||||
-- | 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.Maybe (fromMaybe)
|
||||
import Emit
|
||||
import qualified Env as E
|
||||
import Info
|
||||
import Lookup
|
||||
import qualified Map
|
||||
import qualified Meta
|
||||
import Obj
|
||||
@ -283,8 +283,8 @@ commandBuild ctx [XObj (Bol shutUp) _ _] = do
|
||||
proj = contextProj ctx
|
||||
execMode = contextExecMode ctx
|
||||
src = do
|
||||
typeDecl <- typeEnvToDeclarations typeEnv env
|
||||
decl <- envToDeclarations typeEnv env
|
||||
typeDecl <- envToDeclarations typeEnv (getTypeEnv typeEnv)
|
||||
c <- envToC env Functions
|
||||
initGlobals <- fmap (wrapInInitFunction (projectCore proj)) (globalsToC env)
|
||||
pure
|
||||
@ -726,12 +726,12 @@ commandSaveDocsInternal ctx modulePath = do
|
||||
where
|
||||
getEnvironmentBinderForDocumentation :: Context -> Env -> SymPath -> Either String Binder
|
||||
getEnvironmentBinderForDocumentation _ env path =
|
||||
case lookupBinder path env of
|
||||
Just foundBinder@(Binder _ (XObj (Mod _) _ _)) ->
|
||||
case E.searchValueBinder env path of
|
||||
Right foundBinder@(Binder _ (XObj (Mod _ _) _ _)) ->
|
||||
Right foundBinder
|
||||
Just (Binder _ x) ->
|
||||
Right (Binder _ x) ->
|
||||
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 ++ "`")
|
||||
|
||||
-- | 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 ctx xobj bol =
|
||||
let tyEnv = getTypeEnv $ contextTypeEnv ctx
|
||||
let tyEnv = contextTypeEnv ctx
|
||||
in case xobj of
|
||||
(XObj (Lst [inter@(XObj (Interface ty _) _ _), path]) i t) ->
|
||||
pure (ctx, Right (XObj (Lst [toSymbols inter, path, reify ty]) i t))
|
||||
(XObj (Lst forms) i t) ->
|
||||
pure (ctx, Right (XObj (Lst (map toSymbols forms)) i t))
|
||||
mdl@(XObj (Mod e) _ _) ->
|
||||
mdl@(XObj (Mod e _) _ _) ->
|
||||
if bol
|
||||
then getMod
|
||||
else case lookupBinder (SymPath [] (fromMaybe "" (envModuleName e))) tyEnv of
|
||||
Just (Binder _ (XObj (Lst forms) i t)) ->
|
||||
else case E.getTypeBinder tyEnv (fromMaybe "" (envModuleName e)) of
|
||||
Right (Binder _ (XObj (Lst forms) i t)) ->
|
||||
pure (ctx, Right (XObj (Lst (map toSymbols forms)) i t))
|
||||
Just (Binder _ xobj') ->
|
||||
Right (Binder _ xobj') ->
|
||||
pure (ctx, Right (toSymbols xobj'))
|
||||
Nothing ->
|
||||
Left _ ->
|
||||
getMod
|
||||
where
|
||||
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)
|
||||
|
||||
toSymbols :: XObj -> XObj
|
||||
toSymbols (XObj (Mod e) i t) =
|
||||
toSymbols (XObj (Mod e _) i t) =
|
||||
XObj
|
||||
( Lst
|
||||
[ XObj (Sym (SymPath [] "defmodule") Symbol) i t,
|
||||
@ -866,7 +866,7 @@ commandType ctx (XObj x _ _) =
|
||||
typeOf Break = "dreak"
|
||||
typeOf If = "if"
|
||||
typeOf (Match _) = "matxch"
|
||||
typeOf (Mod _) = "module"
|
||||
typeOf (Mod _ _) = "module"
|
||||
typeOf (Deftype _) = "deftype"
|
||||
typeOf (DefSumtype _) = "def-sum-type"
|
||||
typeOf With = "with"
|
||||
|
@ -5,12 +5,12 @@ module Concretize where
|
||||
import AssignTypes
|
||||
import Constraints
|
||||
import Control.Monad.State
|
||||
import Data.Either (fromRight)
|
||||
import Data.List (foldl')
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Debug.Trace
|
||||
import Env
|
||||
import Env (envIsExternal, findPoly, getTypeBinder, getValue, insert, insertX, lookupEverywhere, searchValue)
|
||||
import Info
|
||||
import Lookup
|
||||
import Managed
|
||||
import qualified Map
|
||||
import Obj
|
||||
@ -87,8 +87,10 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
|
||||
let functionEnv = Env Map.empty (Just env) Nothing Set.empty InternalEnv 0
|
||||
envWithArgs =
|
||||
foldl'
|
||||
( \e arg@(XObj (Sym (SymPath _ argSymName) _) _ _) ->
|
||||
extendEnv e argSymName arg
|
||||
( \e arg@(XObj (Sym path _) _ _) ->
|
||||
-- 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
|
||||
argsArr
|
||||
@ -115,8 +117,8 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
|
||||
functionEnv = Env Map.empty (Just env) Nothing Set.empty InternalEnv (envFunctionNestingLevel env)
|
||||
envWithArgs =
|
||||
foldl'
|
||||
( \e arg@(XObj (Sym (SymPath _ argSymName) _) _ _) ->
|
||||
extendEnv e argSymName arg
|
||||
( \e arg@(XObj (Sym path _) _ _) ->
|
||||
let Right v = insertX e path arg in v
|
||||
)
|
||||
functionEnv
|
||||
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,
|
||||
-- plus the identifier of the particular s-expression that defines the lambda.
|
||||
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
|
||||
environmentTypeName = pathToC lambdaPath ++ "_ty"
|
||||
tyPath = (SymPath [] environmentTypeName)
|
||||
extendedArgs =
|
||||
if null capturedVars
|
||||
then args
|
||||
@ -143,7 +147,7 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
|
||||
( XObj
|
||||
(Sym (SymPath [] "_env") Symbol)
|
||||
(Just dummyInfo)
|
||||
(Just (PointerTy (StructTy (ConcreteNameTy environmentTypeName) []))) :
|
||||
(Just (PointerTy (StructTy (ConcreteNameTy tyPath) []))) :
|
||||
argsArr
|
||||
)
|
||||
)
|
||||
@ -158,13 +162,12 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
|
||||
[XObj (Sym path Symbol) Nothing Nothing, reify symTy]
|
||||
)
|
||||
capturedVars
|
||||
environmentTypeName = pathToC lambdaPath ++ "_env"
|
||||
environmentStructTy = StructTy (ConcreteNameTy environmentTypeName) []
|
||||
environmentStructTy = StructTy (ConcreteNameTy tyPath) []
|
||||
environmentStruct =
|
||||
XObj
|
||||
( Lst
|
||||
[ XObj (Deftype environmentStructTy) Nothing Nothing,
|
||||
XObj (Sym (SymPath [] environmentTypeName) Symbol) Nothing Nothing,
|
||||
XObj (Sym tyPath Symbol) Nothing Nothing,
|
||||
XObj (Arr structMemberPairs) Nothing Nothing
|
||||
]
|
||||
)
|
||||
@ -178,8 +181,9 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
|
||||
copyFnTemplate = concreteCopyPtr typeEnv env pairs
|
||||
(copyFn, copyDeps) = instantiateTemplate (SymPath [] (environmentTypeName ++ "_copy")) copyFnTy copyFnTemplate
|
||||
-- The type env has to contain the lambdas environment struct for 'concretizeDefinition' to work:
|
||||
extendedTypeEnv = TypeEnv (extendEnv (getTypeEnv typeEnv) environmentTypeName environmentStruct)
|
||||
in case concretizeDefinition allowAmbig extendedTypeEnv env visitedDefinitions lambdaCallback funcTy of
|
||||
-- TODO: Fixup: Support modules in type envs.
|
||||
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)
|
||||
Right (concreteLiftedLambda, deps) ->
|
||||
do
|
||||
@ -260,14 +264,14 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
|
||||
pure [okVisitedLhs, okVisitedRhs]
|
||||
visitSymbol :: Bool -> Env -> XObj -> State [XObj] (Either TypeError XObj)
|
||||
visitSymbol allowAmbig env xobj@(XObj (Sym path lookupMode) i t) =
|
||||
case lookupInEnv path env of
|
||||
Just (foundEnv, binder)
|
||||
case searchValue env path of
|
||||
Right (foundEnv, binder)
|
||||
| envIsExternal foundEnv ->
|
||||
let theXObj = binderXObj binder
|
||||
Just theType = xobjTy theXObj
|
||||
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) $
|
||||
isTypeGeneric theType && not (isTypeGeneric typeOfVisited)
|
||||
(isTypeGeneric theType && not (isTypeGeneric typeOfVisited))
|
||||
then case concretizeDefinition allowAmbig typeEnv env visitedDefinitions theXObj typeOfVisited of
|
||||
Left err -> pure (Left err)
|
||||
Right (concrete, deps) ->
|
||||
@ -277,7 +281,7 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
|
||||
pure (Right (XObj (Sym (getPath concrete) lookupMode) i t))
|
||||
else pure (Right xobj)
|
||||
| otherwise -> pure (Right xobj)
|
||||
Nothing -> pure (Right xobj)
|
||||
_ -> pure (Right xobj)
|
||||
visitSymbol _ _ _ = error "Not a symbol."
|
||||
visitMultiSym :: Bool -> Env -> XObj -> State [XObj] (Either TypeError XObj)
|
||||
visitMultiSym allowAmbig env xobj@(XObj (MultiSym originalSymbolName paths) i t) =
|
||||
@ -296,12 +300,13 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
|
||||
Just i' = i
|
||||
in case solve [Constraint theType t' fake1 fake2 fake1 OrdMultiSym] of
|
||||
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?
|
||||
normalSymbol = XObj (Sym singlePath mode) i (Just suffixed)
|
||||
in visitSymbol
|
||||
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
|
||||
Left failure@(UnificationFailure _ _) ->
|
||||
pure $
|
||||
@ -317,8 +322,8 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
|
||||
visitMultiSym _ _ _ = error "Not a multi symbol."
|
||||
visitInterfaceSym :: Bool -> Env -> XObj -> State [XObj] (Either TypeError XObj)
|
||||
visitInterfaceSym allowAmbig env xobj@(XObj (InterfaceSym name) i t) =
|
||||
case lookupBinder (SymPath [] name) (getTypeEnv typeEnv) of
|
||||
Just (Binder _ (XObj (Lst [XObj (Interface _ interfacePaths) _ _, _]) _ _)) ->
|
||||
case getTypeBinder typeEnv name of
|
||||
Right (Binder _ (XObj (Lst [XObj (Interface _ interfacePaths) _ _, _]) _ _)) ->
|
||||
let Just actualType = t
|
||||
tys = map (typeFromPath env) interfacePaths
|
||||
tysToPathsDict = zip tys interfacePaths
|
||||
@ -347,8 +352,8 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
|
||||
allowAmbig
|
||||
env -- trace ("Replacing symbol " ++ pretty xobj ++ " with type " ++ show theType ++ " to single path " ++ show singlePath)
|
||||
normalSymbol
|
||||
Just _ -> error "visitinterfacesym1"
|
||||
Nothing ->
|
||||
Right _ -> error "visitinterfacesym1"
|
||||
Left _ ->
|
||||
error ("No interface named '" ++ name ++ "' found.")
|
||||
visitInterfaceSym _ _ _ = error "visitinterfacesym"
|
||||
|
||||
@ -363,11 +368,11 @@ collectCapturedVars root = removeDuplicates (map decreaseCaptureLevel (visit roo
|
||||
removeDuplicates :: Ord a => [a] -> [a]
|
||||
removeDuplicates = Set.toList . Set.fromList
|
||||
decreaseCaptureLevel :: XObj -> XObj
|
||||
decreaseCaptureLevel (XObj (Sym path lookup) _ ty) =
|
||||
decreaseCaptureLevel (XObj (Sym path lookup') _ ty) =
|
||||
XObj
|
||||
( Sym
|
||||
path
|
||||
( case lookup of
|
||||
( case lookup' of
|
||||
Symbol -> Symbol
|
||||
LookupLocal NoCapture -> Symbol
|
||||
LookupLocal (Capture n) ->
|
||||
@ -436,43 +441,41 @@ concretizeType _ ft@FuncTy {} =
|
||||
if isTypeGeneric ft
|
||||
then Right []
|
||||
else Right [defineFunctionTypeAlias ft]
|
||||
concretizeType typeEnv arrayTy@(StructTy (ConcreteNameTy "Array") varTys) =
|
||||
concretizeType typeEnv arrayTy@(StructTy (ConcreteNameTy (SymPath [] "Array")) varTys) =
|
||||
if isTypeGeneric arrayTy
|
||||
then Right []
|
||||
else do
|
||||
deps <- mapM (concretizeType typeEnv) varTys
|
||||
Right (defineArrayTypeAlias arrayTy : concat deps)
|
||||
-- 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
|
||||
then Right []
|
||||
else do
|
||||
deps <- mapM (concretizeType typeEnv) varTys
|
||||
Right (defineStaticArrayTypeAlias arrayTy : concat deps)
|
||||
-- TODO: handle polymorphic constructors (a b)
|
||||
concretizeType typeEnv genericStructTy@(StructTy (ConcreteNameTy name) _) =
|
||||
case lookupInEnv (SymPath lookupPath structName) (getTypeEnv typeEnv) of
|
||||
Just (_, Binder _ (XObj (Lst (XObj (Deftype originalStructTy) _ _ : _ : rest)) _ _)) ->
|
||||
concretizeType typeEnv genericStructTy@(StructTy (ConcreteNameTy (SymPath _ name)) _) =
|
||||
-- TODO: This function only looks up direct children of the type environment.
|
||||
-- However, spath can point to types that belong to a module. Pass the global env here.
|
||||
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
|
||||
then instantiateGenericStructType typeEnv originalStructTy genericStructTy rest
|
||||
else Right []
|
||||
Just (_, Binder _ (XObj (Lst (XObj (DefSumtype originalStructTy) _ _ : _ : rest)) _ _)) ->
|
||||
go (XObj (Lst (XObj (DefSumtype originalStructTy) _ _ : _ : rest)) _ _) =
|
||||
if isTypeGeneric originalStructTy
|
||||
then instantiateGenericSumtype typeEnv originalStructTy genericStructTy rest
|
||||
else Right []
|
||||
Just (_, Binder _ (XObj (Lst (XObj (ExternalType _) _ _ : _)) _ _)) ->
|
||||
Right []
|
||||
Just (_, Binder _ x) ->
|
||||
error ("Non-deftype found in type env: " ++ show x)
|
||||
Nothing ->
|
||||
Right []
|
||||
where
|
||||
lookupPath = getPathFromStructName name
|
||||
structName = getNameFromStructName name
|
||||
concretizeType env (RefTy rt _) =
|
||||
concretizeType env rt
|
||||
concretizeType env (PointerTy pt) =
|
||||
concretizeType env pt
|
||||
go (XObj (Lst (XObj (ExternalType _) _ _ : _)) _ _) = Right []
|
||||
go x = error ("Non-deftype found in type env: " ++ pretty x)
|
||||
concretizeType t (RefTy rt _) =
|
||||
concretizeType t rt
|
||||
concretizeType t (PointerTy pt) =
|
||||
concretizeType t pt
|
||||
concretizeType _ _ =
|
||||
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.
|
||||
typeFromPath :: Env -> SymPath -> Ty
|
||||
typeFromPath env p =
|
||||
case lookupInEnv p env of
|
||||
Just (e, Binder _ found)
|
||||
case searchValue env p of
|
||||
Right (e, Binder _ found)
|
||||
| envIsExternal e -> forceTy found
|
||||
| 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.
|
||||
-- |
|
||||
@ -604,14 +607,14 @@ typeFromPath env p =
|
||||
-- | parts of doesNotBelongToAnInterface.
|
||||
modeFromPath :: Env -> SymPath -> SymbolMode
|
||||
modeFromPath env p =
|
||||
case lookupInEnv p env of
|
||||
Just (_, Binder _ (XObj (Lst (XObj (External (Just overrideWithName)) _ _ : _)) _ _)) ->
|
||||
case searchValue env p of
|
||||
Right (_, Binder _ (XObj (Lst (XObj (External (Just overrideWithName)) _ _ : _)) _ _)) ->
|
||||
LookupGlobalOverride overrideWithName
|
||||
Just (_, Binder _ (XObj (Lst (XObj (ExternalType (Just overrideWithName)) _ _ : _)) _ _)) ->
|
||||
Right (_, Binder _ (XObj (Lst (XObj (ExternalType (Just overrideWithName)) _ _ : _)) _ _)) ->
|
||||
LookupGlobalOverride overrideWithName
|
||||
Just (_, Binder _ found@(XObj (Lst (XObj (External _) _ _ : _)) _ _)) ->
|
||||
Right (_, Binder _ found@(XObj (Lst (XObj (External _) _ _ : _)) _ _)) ->
|
||||
LookupGlobal ExternalCode (definitionMode found)
|
||||
Just (e, Binder _ found) ->
|
||||
Right (e, Binder _ found) ->
|
||||
case envMode e of
|
||||
ExternalEnv ->
|
||||
LookupGlobal CarpLand (definitionMode found)
|
||||
@ -622,7 +625,7 @@ modeFromPath env p =
|
||||
then Capture (envFunctionNestingLevel e - envFunctionNestingLevel env)
|
||||
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
|
||||
-- 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.
|
||||
allImplementations :: TypeEnv -> Env -> String -> Ty -> [(Env, Binder)]
|
||||
allImplementations typeEnv env functionName functionType =
|
||||
filter (predicate . xobjTy . binderXObj . snd) foundBindings
|
||||
(filter (predicate . xobjTy . binderXObj . snd) foundBindings)
|
||||
where
|
||||
predicate (Just t) =
|
||||
--trace ("areUnifiable? " ++ show functionType ++ " == " ++ show t ++ " " ++ show (areUnifiable functionType t)) $
|
||||
areUnifiable functionType t
|
||||
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
|
||||
Just (Binder _ (XObj (Lst (XObj (Interface _ paths) _ _ : _)) _ _)) ->
|
||||
-- N.B./TODO: There are functions designed for this
|
||||
-- scenario--e.g. lookupImplementations, but they cause
|
||||
-- either entirely unacceptable behavior (not finding
|
||||
-- implementations, or hangs). We should be able to use
|
||||
-- those here instead of looking up all interface paths
|
||||
-- directly, but for now we are stuck with this.
|
||||
case sequence $ map (\p -> lookupInEnv p env) (paths ++ [(SymPath [] functionName)]) of
|
||||
Just found -> found
|
||||
Nothing -> (multiLookupEverywhere functionName env)
|
||||
Right (Binder _ (XObj (Lst (XObj (Interface _ paths) _ _ : _)) _ _)) ->
|
||||
case sequence $ map (\p -> searchValue env p) (paths ++ [(SymPath [] functionName)]) of
|
||||
Right found -> found
|
||||
Left _ ->
|
||||
case findPoly env functionName functionType of
|
||||
Right r -> [r]
|
||||
Left _ -> (lookupEverywhere env functionName)
|
||||
-- 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.
|
||||
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
|
||||
do
|
||||
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
|
||||
Just pathOfDeleteFunc ->
|
||||
ProperDeleter pathOfDeleteFunc (getDropFunc (xobjInfo xobj) t) var
|
||||
|
194
src/Context.hs
194
src/Context.hs
@ -1,5 +1,6 @@
|
||||
module Context
|
||||
( replaceGlobalEnv,
|
||||
( ContextError (..),
|
||||
replaceGlobalEnv,
|
||||
replaceInternalEnv,
|
||||
replaceTypeEnv,
|
||||
replaceHistory,
|
||||
@ -9,27 +10,82 @@ module Context
|
||||
replaceInternalEnv',
|
||||
replaceTypeEnv',
|
||||
replaceHistory',
|
||||
replacePath',
|
||||
insertInGlobalEnv,
|
||||
insertInGlobalEnv',
|
||||
insertInTypeEnv,
|
||||
insertInTypeEnv',
|
||||
insertTypeBinder,
|
||||
insertTypeBinder',
|
||||
insertInInternalEnv,
|
||||
insertType,
|
||||
replaceTypeBinder,
|
||||
innermostModuleEnv,
|
||||
bindLetDeclaration,
|
||||
lookupInterface,
|
||||
lookupBinderInGlobalEnv,
|
||||
lookupBinderInInternalEnv,
|
||||
lookupBinderInTypeEnv,
|
||||
lookupBinderInContextEnv,
|
||||
contextualize,
|
||||
)
|
||||
where
|
||||
|
||||
import Env
|
||||
import Lookup
|
||||
import Data.Bifunctor
|
||||
import Debug.Trace
|
||||
import qualified Env as E
|
||||
import Obj
|
||||
import Project
|
||||
import Qualify (QualifiedPath, qualifyPath, unqualify)
|
||||
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
|
||||
@ -113,6 +169,10 @@ replaceTypeEnv' = flip replaceTypeEnv
|
||||
replaceHistory' :: [XObj] -> Context -> Context
|
||||
replaceHistory' = flip replaceHistory
|
||||
|
||||
-- | replacePath with arguments flipped.
|
||||
replacePath' :: [String] -> Context -> Context
|
||||
replacePath' = flip replacePath
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Binding Insertion Functions
|
||||
|
||||
@ -121,70 +181,110 @@ replaceHistory' = flip replaceHistory
|
||||
-- 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
|
||||
-- function.
|
||||
insertInGlobalEnv :: Context -> QualifiedPath -> Binder -> Context
|
||||
insertInGlobalEnv :: Context -> QualifiedPath -> Binder -> Either ContextError Context
|
||||
insertInGlobalEnv ctx qpath binder =
|
||||
let globalEnv = contextGlobalEnv ctx
|
||||
in ctx {contextGlobalEnv = envInsertAt globalEnv (unqualify qpath) binder}
|
||||
replaceLeft
|
||||
(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.
|
||||
--
|
||||
-- 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
|
||||
-- function.
|
||||
insertInTypeEnv :: Context -> QualifiedPath -> Binder -> Context
|
||||
insertInTypeEnv ctx qpath binder =
|
||||
let typeEnv = getTypeEnv (contextTypeEnv ctx)
|
||||
in ctx {contextTypeEnv = TypeEnv (envInsertAt typeEnv (unqualify qpath) binder)}
|
||||
insertTypeBinder :: Context -> QualifiedPath -> Binder -> Either ContextError Context
|
||||
insertTypeBinder ctx qpath binder =
|
||||
let (SymPath path name) = unqualify qpath
|
||||
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.
|
||||
--
|
||||
-- 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 =
|
||||
ctx {contextInternalEnv = fmap insert (contextInternalEnv ctx)}
|
||||
maybe
|
||||
(Left (FailedToInsertInInternalEnv path binder))
|
||||
insert'
|
||||
(contextInternalEnv ctx)
|
||||
where
|
||||
insert :: Env -> Env
|
||||
insert e = envInsertAt e path binder
|
||||
insertInInternalEnv _ _ _ =
|
||||
error "attempted to insert a qualified symbol into an internal environment"
|
||||
insert' :: Env -> Either ContextError Context
|
||||
insert' e =
|
||||
replaceLeft
|
||||
(FailedToInsertInInternalEnv path binder)
|
||||
(E.insert e path binder >>= \e' -> pure (ctx {contextInternalEnv = pure e'}))
|
||||
insertInInternalEnv _ path _ = Left (AttemptedToInsertQualifiedInternalBinder path)
|
||||
|
||||
-- | insertInGlobalEnv with arguments flipped.
|
||||
insertInGlobalEnv' :: QualifiedPath -> Binder -> Context -> Context
|
||||
insertInGlobalEnv' :: QualifiedPath -> Binder -> Context -> Either ContextError Context
|
||||
insertInGlobalEnv' path binder ctx = insertInGlobalEnv ctx path binder
|
||||
|
||||
-- | insertInTypeEnv with arguments flipped.
|
||||
insertInTypeEnv' :: QualifiedPath -> Binder -> Context -> Context
|
||||
insertInTypeEnv' path binder ctx = insertInTypeEnv ctx path binder
|
||||
-- | insertTypeBinder with arguments flipped.
|
||||
insertTypeBinder' :: QualifiedPath -> Binder -> Context -> Either ContextError Context
|
||||
insertTypeBinder' path binder ctx = insertTypeBinder ctx path binder
|
||||
|
||||
-- | 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 =
|
||||
let binder = Binder emptyMeta (toLocalDef name xobj)
|
||||
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
|
||||
|
||||
-- | Retrieves the innermost (deepest) module environment in a context
|
||||
-- according to the context's contextPath.
|
||||
--
|
||||
-- Returns Nothing if the Context path is empty.
|
||||
innermostModuleEnv :: Context -> Maybe Env
|
||||
-- Returns an error if the Context path is empty.
|
||||
innermostModuleEnv :: Context -> Either ContextError Env
|
||||
innermostModuleEnv ctx = go (contextPath ctx)
|
||||
where
|
||||
go :: [String] -> Maybe Env
|
||||
go [] = Nothing
|
||||
go xs = Just $ getEnv (contextGlobalEnv ctx) xs
|
||||
go :: [String] -> Either ContextError Env
|
||||
go [] = Left (NoModuleEnvs "")
|
||||
go xs = replaceLeft (NoModuleEnvs (joinWithPeriod xs)) (E.getInnerEnv (contextGlobalEnv ctx) xs)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Binder Lookup Functions
|
||||
|
||||
-- | 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 =
|
||||
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 =
|
||||
decontextualizedLookup lookupBinderInTypeEnv ctx path
|
||||
|
||||
@ -193,30 +293,46 @@ lookupInterface ctx path =
|
||||
-- Depending on the type of path passed to this function, further
|
||||
-- contextualization of the path may be performed before the lookup is
|
||||
-- performed.
|
||||
lookupBinderInTypeEnv :: Contextual a => Context -> a -> Maybe Binder
|
||||
lookupBinderInTypeEnv :: Contextual a => Context -> a -> Either ContextError Binder
|
||||
lookupBinderInTypeEnv ctx path =
|
||||
let typeEnv = getTypeEnv (contextTypeEnv ctx)
|
||||
fullPath = contextualize path ctx
|
||||
in lookupBinder fullPath typeEnv
|
||||
let typeEnv = contextTypeEnv ctx
|
||||
global = contextGlobalEnv ctx
|
||||
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.
|
||||
--
|
||||
-- Depending on the type of path passed to this function, further
|
||||
-- contextualization of the path may be performed before the lookup is
|
||||
-- performed.
|
||||
lookupBinderInGlobalEnv :: Contextual a => Context -> a -> Maybe Binder
|
||||
lookupBinderInGlobalEnv :: Contextual a => Context -> a -> Either ContextError Binder
|
||||
lookupBinderInGlobalEnv ctx path =
|
||||
let global = contextGlobalEnv 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.
|
||||
--
|
||||
-- Depending on the type of path passed to this function, further
|
||||
-- contextualization of the path may be performed before the lookup is
|
||||
-- performed.
|
||||
lookupBinderInContextEnv :: Context -> SymPath -> Maybe Binder
|
||||
lookupBinderInContextEnv :: Context -> SymPath -> Either ContextError Binder
|
||||
lookupBinderInContextEnv ctx path =
|
||||
let ctxEnv = contextEnv ctx
|
||||
let ctxEnv = (E.contextEnv 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
|
||||
( moduleForDeftype,
|
||||
moduleForDeftypeInContext,
|
||||
bindingsForRegisteredType,
|
||||
memberArg,
|
||||
)
|
||||
where
|
||||
|
||||
import Concretize
|
||||
import Context
|
||||
import Data.Maybe
|
||||
import Env
|
||||
import Env (addListOfBindings, new)
|
||||
import Info
|
||||
import Managed
|
||||
import qualified Map
|
||||
import Obj
|
||||
import qualified Set
|
||||
import StructUtils
|
||||
import Template
|
||||
import ToTemplate
|
||||
@ -27,19 +27,41 @@ import Validate
|
||||
|
||||
{-# 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.
|
||||
-- A type module provides a namespace for all the functions that area automatically
|
||||
-- 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 =
|
||||
let typeModuleName = typeName
|
||||
typeModuleEnv = fromMaybe (Env (Map.fromList []) innerEnv (Just typeModuleName) Set.empty ExternalEnv 0) existingEnv
|
||||
let moduleValueEnv = fromMaybe (new innerEnv (Just typeName)) (fmap fst 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'.
|
||||
-- For example (module Vec2 [x Float]) creates bindings like Vec2.create, Vec2.x, etc.
|
||||
insidePath = pathStrings ++ [typeModuleName]
|
||||
insidePath = pathStrings ++ [typeName]
|
||||
in do
|
||||
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
|
||||
okInit <- binderForInit insidePath structTy rest
|
||||
(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
|
||||
(okCopy, copyDeps) <- binderForCopy typeEnv env insidePath structTy rest
|
||||
let funcs = okInit : okStr : okPrn : okDelete : okCopy : okMembers
|
||||
moduleEnvWithBindings = addListOfBindings typeModuleEnv funcs
|
||||
typeModuleXObj = XObj (Mod moduleEnvWithBindings) i (Just ModuleTy)
|
||||
moduleEnvWithBindings = addListOfBindings moduleValueEnv funcs
|
||||
typeModuleXObj = XObj (Mod moduleEnvWithBindings moduleTypeEnv) i (Just ModuleTy)
|
||||
deps = deleteDeps ++ membersDeps ++ copyDeps ++ strDeps
|
||||
pure (typeModuleName, typeModuleXObj, deps)
|
||||
pure (typeName, typeModuleXObj, deps)
|
||||
|
||||
-- | Will generate getters/setters/updaters when registering EXTERNAL types.
|
||||
-- | i.e. (register-type VRUnicornData [hp Int, magic Float])
|
||||
-- | 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 =
|
||||
let typeModuleName = typeName
|
||||
typeModuleEnv = fromMaybe (Env (Map.fromList []) (Just env) (Just typeModuleName) Set.empty ExternalEnv 0) existingEnv
|
||||
insidePath = pathStrings ++ [typeModuleName]
|
||||
let moduleValueEnv = fromMaybe (new (Just env) (Just typeName)) (fmap fst existingEnv)
|
||||
moduleTypeEnv = fromMaybe (new (Just typeEnv) (Just typeName)) (fmap snd existingEnv)
|
||||
insidePath = pathStrings ++ [typeName]
|
||||
in do
|
||||
validateMemberCases typeEnv [] rest
|
||||
let structTy = StructTy (ConcreteNameTy typeName) []
|
||||
let structTy = StructTy (ConcreteNameTy (SymPath pathStrings typeName)) []
|
||||
(binders, deps) <- templatesForMembers typeEnv env insidePath structTy rest
|
||||
okInit <- binderForInit insidePath structTy rest
|
||||
(okStr, strDeps) <- binderForStrOrPrn typeEnv env insidePath structTy rest "str"
|
||||
(okPrn, _) <- binderForStrOrPrn typeEnv env insidePath structTy rest "prn"
|
||||
let moduleEnvWithBindings = addListOfBindings typeModuleEnv (okInit : okStr : okPrn : binders)
|
||||
typeModuleXObj = XObj (Mod moduleEnvWithBindings) i (Just ModuleTy)
|
||||
pure (typeModuleName, typeModuleXObj, deps ++ strDeps)
|
||||
let moduleEnvWithBindings = addListOfBindings moduleValueEnv (okInit : okStr : okPrn : binders)
|
||||
typeModuleXObj = XObj (Mod moduleEnvWithBindings moduleTypeEnv) i (Just ModuleTy)
|
||||
pure (typeName, typeModuleXObj, deps ++ strDeps)
|
||||
|
||||
-- | Generate all the templates for ALL the member variables in a deftype declaration.
|
||||
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.
|
||||
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
|
||||
-- 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
|
||||
@ -101,18 +123,18 @@ templatesForSingleMember typeEnv env insidePath p@(StructTy (ConcreteNameTy type
|
||||
Just t = xobjToTy typeXObj
|
||||
memberName = getName nameXObj
|
||||
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
|
||||
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
|
||||
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
|
||||
(SymPath insidePath ("update-" ++ memberName))
|
||||
updaterSig
|
||||
(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"
|
||||
|
||||
@ -176,12 +198,12 @@ templateSetter typeEnv env memberName memberTy =
|
||||
|
||||
-- | The template for setters of a generic deftype.
|
||||
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
|
||||
where
|
||||
path = SymPath pathStrings ("set-" ++ memberName)
|
||||
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 $
|
||||
\typeEnv env ->
|
||||
Template
|
||||
@ -242,12 +264,12 @@ templateMutatingSetter typeEnv env memberName memberTy =
|
||||
|
||||
-- | The template for mutating setters of a generic deftype.
|
||||
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
|
||||
where
|
||||
path = SymPath pathStrings ("set-" ++ memberName ++ "!")
|
||||
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 $
|
||||
\typeEnv env ->
|
||||
Template
|
||||
@ -313,7 +335,7 @@ templateUpdater member _ =
|
||||
|
||||
-- | Helper function to create the binder for the 'init' template.
|
||||
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
|
||||
then Right (genericInit StackAlloc insidePath structTy membersXObjs)
|
||||
else
|
||||
@ -322,7 +344,7 @@ binderForInit insidePath structTy@(StructTy (ConcreteNameTy typeName) _) [XObj (
|
||||
(SymPath insidePath "init")
|
||||
(FuncTy (initArgListTypes membersXObjs) structTy StaticLifetimeTy)
|
||||
(concreteInit StackAlloc structTy membersXObjs)
|
||||
("creates a `" ++ typeName ++ "`.")
|
||||
("creates a `" ++ show structTy ++ "`.")
|
||||
binderForInit _ _ _ = error "binderforinit"
|
||||
|
||||
-- | 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.
|
||||
concreteInit :: AllocationMode -> Ty -> [XObj] -> Template
|
||||
concreteInit allocationMode originalStructTy@(StructTy (ConcreteNameTy typeName) _) membersXObjs =
|
||||
concreteInit allocationMode originalStructTy@(StructTy (ConcreteNameTy _) _) membersXObjs =
|
||||
Template
|
||||
(FuncTy (map snd (memberXObjsToPairs membersXObjs)) (VarTy "p") StaticLifetimeTy)
|
||||
( \(FuncTy _ concreteStructTy _) ->
|
||||
@ -344,7 +366,7 @@ concreteInit allocationMode originalStructTy@(StructTy (ConcreteNameTy typeName)
|
||||
( \(FuncTy _ concreteStructTy _) ->
|
||||
let mappings = unifySignatures originalStructTy concreteStructTy
|
||||
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
|
||||
in tokensForInit allocationMode typeName correctedMembers
|
||||
in tokensForInit allocationMode (show originalStructTy) correctedMembers
|
||||
)
|
||||
(\FuncTy {} -> [])
|
||||
where
|
||||
@ -353,12 +375,12 @@ concreteInit _ _ _ = error "concreteinit"
|
||||
|
||||
-- | The template for the 'init' and 'new' functions for a generic deftype.
|
||||
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
|
||||
where
|
||||
path = SymPath pathStrings "init"
|
||||
t = FuncTy (map snd (memberXObjsToPairs membersXObjs)) originalStructTy StaticLifetimeTy
|
||||
docs = "creates a `" ++ typeName ++ "`."
|
||||
docs = "creates a `" ++ show originalStructTy ++ "`."
|
||||
templateCreator = TemplateCreator $
|
||||
\typeEnv _ ->
|
||||
Template
|
||||
@ -372,7 +394,7 @@ genericInit allocationMode pathStrings originalStructTy@(StructTy (ConcreteNameT
|
||||
( \(FuncTy _ concreteStructTy _) ->
|
||||
let mappings = unifySignatures originalStructTy concreteStructTy
|
||||
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
|
||||
in tokensForInit allocationMode typeName correctedMembers
|
||||
in tokensForInit allocationMode (show originalStructTy) correctedMembers
|
||||
)
|
||||
( \(FuncTy _ concreteStructTy _) ->
|
||||
case concretizeType typeEnv concreteStructTy of
|
||||
@ -424,7 +446,7 @@ templatizeTy t = t
|
||||
|
||||
-- | 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 insidePath structTy@(StructTy (ConcreteNameTy typeName) _) [XObj (Arr membersXObjs) _ _] strOrPrn =
|
||||
binderForStrOrPrn typeEnv env insidePath structTy@(StructTy (ConcreteNameTy _) _) [XObj (Arr membersXObjs) _ _] strOrPrn =
|
||||
if isTypeGeneric structTy
|
||||
then Right (genericStr insidePath structTy membersXObjs strOrPrn, [])
|
||||
else
|
||||
@ -433,18 +455,18 @@ binderForStrOrPrn typeEnv env insidePath structTy@(StructTy (ConcreteNameTy type
|
||||
(SymPath insidePath strOrPrn)
|
||||
(FuncTy [RefTy structTy (VarTy "q")] StringTy StaticLifetimeTy)
|
||||
(concreteStr typeEnv env structTy (memberXObjsToPairs membersXObjs) strOrPrn)
|
||||
("converts a `" ++ typeName ++ "` to a string.")
|
||||
("converts a `" ++ show structTy ++ "` to a string.")
|
||||
)
|
||||
binderForStrOrPrn _ _ _ _ _ _ = error "binderforstrorprn"
|
||||
|
||||
-- | The template for the 'str' function for a concrete deftype.
|
||||
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
|
||||
(FuncTy [RefTy concreteStructTy (VarTy "q")] StringTy StaticLifetimeTy)
|
||||
(\(FuncTy [RefTy structTy _] StringTy _) -> toTemplate $ "String $NAME(" ++ tyToCLambdaFix structTy ++ " *p)")
|
||||
( \(FuncTy [RefTy (StructTy _ _) _] StringTy _) ->
|
||||
tokensForStr typeEnv env typeName memberPairs concreteStructTy
|
||||
tokensForStr typeEnv env (show name) memberPairs concreteStructTy
|
||||
)
|
||||
( \(FuncTy [RefTy (StructTy _ _) (VarTy "q")] StringTy _) ->
|
||||
concatMap
|
||||
@ -455,12 +477,12 @@ concreteStr _ _ _ _ _ = error "concretestr"
|
||||
|
||||
-- | The template for the 'str' function for a generic deftype.
|
||||
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
|
||||
where
|
||||
path = SymPath pathStrings strOrPrn
|
||||
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 $
|
||||
\typeEnv env ->
|
||||
Template
|
||||
@ -472,7 +494,7 @@ genericStr pathStrings originalStructTy@(StructTy (ConcreteNameTy typeName) _) m
|
||||
let mappings = unifySignatures originalStructTy concreteStructTy
|
||||
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
|
||||
memberPairs = memberXObjsToPairs correctedMembers
|
||||
in tokensForStr typeEnv env typeName memberPairs concreteStructTy
|
||||
in tokensForStr typeEnv env (show name) memberPairs concreteStructTy
|
||||
)
|
||||
( \ft@(FuncTy [RefTy concreteStructTy@(StructTy _ _) _] StringTy _) ->
|
||||
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.
|
||||
calculateStructStrSize :: TypeEnv -> Env -> [(String, Ty)] -> Ty -> String
|
||||
calculateStructStrSize typeEnv env members (StructTy (ConcreteNameTy name) _) =
|
||||
" int size = snprintf(NULL, 0, \"(%s )\", \"" ++ name ++ "\");\n"
|
||||
calculateStructStrSize typeEnv env members s@(StructTy (ConcreteNameTy _) _) =
|
||||
" int size = snprintf(NULL, 0, \"(%s )\", \"" ++ show s ++ "\");\n"
|
||||
++ unlines (map (memberPrnSize typeEnv env) members)
|
||||
calculateStructStrSize _ _ _ _ = error "calculatestructstrsize"
|
||||
|
||||
@ -525,7 +547,7 @@ memberAssignment allocationMode memberName = " instance" ++ sep ++ memberName
|
||||
|
||||
-- | Helper function to create the binder for the 'delete' template.
|
||||
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
|
||||
then Right (genericDelete insidePath structTy membersXObjs, [])
|
||||
else
|
||||
@ -534,18 +556,18 @@ binderForDelete typeEnv env insidePath structTy@(StructTy (ConcreteNameTy typeNa
|
||||
(SymPath insidePath "delete")
|
||||
(FuncTy [structTy] UnitTy StaticLifetimeTy)
|
||||
(concreteDelete typeEnv env (memberXObjsToPairs membersXObjs))
|
||||
("deletes a `" ++ typeName ++ "`.")
|
||||
("deletes a `" ++ show structTy ++ "`.")
|
||||
)
|
||||
binderForDelete _ _ _ _ _ = error "binderfordelete"
|
||||
|
||||
-- | The template for the 'delete' function of a generic deftype.
|
||||
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
|
||||
where
|
||||
path = SymPath pathStrings "delete"
|
||||
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 $
|
||||
\typeEnv env ->
|
||||
Template
|
||||
@ -578,7 +600,7 @@ genericDelete _ _ _ = error "genericdelete"
|
||||
|
||||
-- | Helper function to create the binder for the 'copy' template.
|
||||
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
|
||||
then Right (genericCopy insidePath structTy membersXObjs, [])
|
||||
else
|
||||
@ -587,18 +609,18 @@ binderForCopy typeEnv env insidePath structTy@(StructTy (ConcreteNameTy typeName
|
||||
(SymPath insidePath "copy")
|
||||
(FuncTy [RefTy structTy (VarTy "q")] structTy StaticLifetimeTy)
|
||||
(concreteCopy typeEnv env (memberXObjsToPairs membersXObjs))
|
||||
("copies a `" ++ typeName ++ "`.")
|
||||
("copies a `" ++ show structTy ++ "`.")
|
||||
)
|
||||
binderForCopy _ _ _ _ _ = error "binderforcopy"
|
||||
|
||||
-- | The template for the 'copy' function of a generic deftype.
|
||||
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
|
||||
where
|
||||
path = SymPath pathStrings "copy"
|
||||
t = FuncTy [RefTy (VarTy "p") (VarTy "q")] (VarTy "p") StaticLifetimeTy
|
||||
docs = "copies the `" ++ typeName ++ "`."
|
||||
docs = "copies the `" ++ show originalStructTy ++ "`."
|
||||
templateCreator = TemplateCreator $
|
||||
\typeEnv env ->
|
||||
Template
|
||||
|
61
src/Emit.hs
61
src/Emit.hs
@ -8,6 +8,7 @@ module Emit
|
||||
checkForUnresolvedSymbols,
|
||||
ToCMode (..),
|
||||
wrapInInitFunction,
|
||||
typeEnvToDeclarations,
|
||||
)
|
||||
where
|
||||
|
||||
@ -139,7 +140,7 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
|
||||
x -> show (ord x) ++ "/*" ++ show x ++ "*/" -- ['U', '\'', x, '\'']
|
||||
Closure elt _ -> visit indent elt
|
||||
Sym _ _ -> visitSymbol indent xobj
|
||||
Mod _ -> error (show (CannotEmitModKeyword xobj))
|
||||
Mod _ _ -> error (show (CannotEmitModKeyword xobj))
|
||||
External _ -> error (show (CannotEmitExternal xobj))
|
||||
(Defn _) -> dontVisit
|
||||
Def -> dontVisit
|
||||
@ -258,7 +259,7 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
|
||||
Just callback = name
|
||||
callbackMangled = pathToC callback
|
||||
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) []
|
||||
lambdaEnvName = freshVar info ++ "_env"
|
||||
appendToSrc
|
||||
@ -293,8 +294,8 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
|
||||
appendToSrc (addIndent indent ++ "Lambda " ++ retVar ++ " = {\n")
|
||||
appendToSrc (addIndent indent ++ " .callback = (void*)" ++ callbackMangled ++ ",\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 ++ " .copy = (void*)" ++ (if needEnv then "" ++ lambdaEnvTypeName ++ "_copy" 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 "" ++ show lambdaEnvTypeName ++ "_copy" else "NULL") ++ "\n")
|
||||
appendToSrc (addIndent indent ++ "};\n")
|
||||
pure retVar
|
||||
-- Def
|
||||
@ -661,8 +662,8 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
|
||||
else tyToCLambdaFix retTy ++ "(*)(" ++ joinWithComma (map tyToCLambdaFix voidless) ++ ")"
|
||||
castToFnWithEnv =
|
||||
if unwrapLambdas
|
||||
then tyToCLambdaFix retTy ++ "(*)(" ++ joinWithComma (map tyToCRawFunctionPtrFix (StructTy (ConcreteNameTy "LambdaEnv") [] : voidless)) ++ ")"
|
||||
else tyToCLambdaFix retTy ++ "(*)(" ++ joinWithComma (map tyToCLambdaFix (StructTy (ConcreteNameTy "LambdaEnv") [] : voidless)) ++ ")"
|
||||
then tyToCLambdaFix retTy ++ "(*)(" ++ joinWithComma (map tyToCRawFunctionPtrFix (StructTy (ConcreteNameTy (SymPath [] "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"
|
||||
if isUnit retTy
|
||||
then do
|
||||
@ -703,7 +704,7 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
|
||||
do
|
||||
let arrayVar = freshVar i
|
||||
len = length xobjs
|
||||
Just (StructTy (ConcreteNameTy "Array") [innerTy]) = t
|
||||
Just (StructTy (ConcreteNameTy (SymPath [] "Array")) [innerTy]) = t
|
||||
appendToSrc
|
||||
( addIndent indent ++ "Array " ++ arrayVar
|
||||
++ " = { .len = "
|
||||
@ -744,7 +745,7 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
|
||||
retVar = arrayVar ++ "_retref"
|
||||
arrayDataVar = arrayVar ++ "_data"
|
||||
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 ++ "Array " ++ arrayVar
|
||||
@ -960,7 +961,7 @@ binderToC toCMode binder =
|
||||
XObj (External _) _ _ -> Right ""
|
||||
XObj (ExternalType _) _ _ -> Right ""
|
||||
XObj (Command _) _ _ -> Right ""
|
||||
XObj (Mod env) _ _ -> envToC env toCMode
|
||||
XObj (Mod env _) _ _ -> envToC env toCMode
|
||||
_ -> case xobjTy xobj of
|
||||
Just t ->
|
||||
if isTypeGeneric t
|
||||
@ -974,16 +975,16 @@ binderToDeclaration :: TypeEnv -> Binder -> Either ToCError String
|
||||
binderToDeclaration typeEnv binder =
|
||||
let xobj = binderXObj binder
|
||||
in case xobj of
|
||||
XObj (Mod env) _ _ -> envToDeclarations typeEnv env
|
||||
XObj (Mod env _) _ _ -> envToDeclarations typeEnv env
|
||||
_ -> case xobjTy xobj of
|
||||
Just t -> if isTypeGeneric t then Right "" else Right (toDeclaration binder ++ "")
|
||||
Nothing -> Left (BinderIsMissingType binder)
|
||||
|
||||
envToC :: Env -> ToCMode -> Either ToCError String
|
||||
envToC env toCMode =
|
||||
let binders = Map.toList (envBindings env)
|
||||
let binders' = Map.toList (envBindings env)
|
||||
in do
|
||||
okCodes <- mapM (binderToC toCMode . snd) binders
|
||||
okCodes <- mapM (binderToC toCMode . snd) binders'
|
||||
pure (concat okCodes)
|
||||
|
||||
globalsToC :: Env -> Either ToCError String
|
||||
@ -1000,6 +1001,34 @@ globalsToC globalEnv =
|
||||
(sortGlobalVariableBinders globalEnv allGlobalBinders)
|
||||
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 =
|
||||
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)
|
||||
|
||||
sortDeclarationBinders :: TypeEnv -> [Binder] -> [(Int, Binder)]
|
||||
sortDeclarationBinders typeEnv binders =
|
||||
sortDeclarationBinders 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 globalEnv binders =
|
||||
sortOn fst (map (scoreValueBinder globalEnv Set.empty) binders)
|
||||
sortGlobalVariableBinders globalEnv binders' =
|
||||
sortOn fst (map (scoreValueBinder globalEnv Set.empty) binders')
|
||||
|
||||
checkForUnresolvedSymbols :: XObj -> Either ToCError ()
|
||||
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 qualified Map
|
||||
import qualified Meta
|
||||
import Obj
|
||||
import qualified Set
|
||||
import Types
|
||||
|
||||
-- | Add an XObj to a specific environment. TODO: rename to envInsert
|
||||
extendEnv :: Env -> String -> XObj -> Env
|
||||
extendEnv env name xobj = envAddBinding env name (Binder emptyMeta xobj)
|
||||
--------------------------------------------------------------------------------
|
||||
-- Data
|
||||
|
||||
-- | Add a Binder to an environment at a specific path location.
|
||||
envInsertAt :: Env -> SymPath -> Binder -> Env
|
||||
envInsertAt env (SymPath [] name) binder =
|
||||
envAddBinding env name binder
|
||||
envInsertAt env (SymPath (p : ps) name) xobj =
|
||||
case Map.lookup p (envBindings env) of
|
||||
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)
|
||||
data EnvironmentError
|
||||
= NoEnvInNonModule
|
||||
| NoReplaceInNonModule
|
||||
| BindingNotFound String Env
|
||||
| NoMatchingBindingFound String
|
||||
| NestedTypeError String
|
||||
|
||||
envReplaceEnvAt :: Env -> [String] -> Env -> Env
|
||||
envReplaceEnvAt _ [] replacement = replacement
|
||||
envReplaceEnvAt env (p : ps) replacement =
|
||||
case Map.lookup p (envBindings env) of
|
||||
Just (Binder _ (XObj (Mod innerEnv) i t)) ->
|
||||
let newInnerEnv = Binder emptyMeta (XObj (Mod (envReplaceEnvAt innerEnv ps replacement)) i t)
|
||||
in env {envBindings = Map.insert p newInnerEnv (envBindings env)}
|
||||
Just _ -> error ("Can't replace non-module: " ++ p)
|
||||
Nothing -> error ("Can't replace non-existing module: " ++ p)
|
||||
instance Show EnvironmentError where
|
||||
show NoEnvInNonModule = "Can't get an environment from a non-module."
|
||||
show NoReplaceInNonModule = "Can't replace an environment in a non-module."
|
||||
show (BindingNotFound name e) = "Failed to find " ++ name ++ "in the given environment: " ++ show e
|
||||
show (NoMatchingBindingFound predicate) = "Couldn't find any bindings with " ++ predicate ++ "in the given environment."
|
||||
show (NestedTypeError name) =
|
||||
"Couldn't insert the top-level type " ++ name
|
||||
++ " in a module environment."
|
||||
|
||||
-- | Add a Binder to a specific environment.
|
||||
envAddBinding :: Env -> String -> Binder -> Env
|
||||
envAddBinding env name binder = env {envBindings = Map.insert name binder (envBindings env)}
|
||||
data Mode = Types | Values
|
||||
|
||||
{-# ANN addListOfBindings "HLint: ignore Eta reduce" #-}
|
||||
--------------------------------------------------------------------------------
|
||||
-- The Environment class and implementations
|
||||
|
||||
-- | Add a list of bindings to an environment
|
||||
addListOfBindings :: Env -> [(String, Binder)] -> Env
|
||||
addListOfBindings env bindingsToAdd = foldl' (\e (n, b) -> envAddBinding e n b) env bindingsToAdd
|
||||
-- | Class for generically handling type and value environments.
|
||||
class Environment e where
|
||||
inj :: Env -> e
|
||||
prj :: e -> Env
|
||||
update :: e -> Binder -> Either EnvironmentError Binder
|
||||
modality :: e -> Mode
|
||||
|
||||
-- | Get an inner environment.
|
||||
getEnv :: Env -> [String] -> Env
|
||||
getEnv env [] = env
|
||||
getEnv env (p : ps) = case Map.lookup p (envBindings env) of
|
||||
Just (Binder _ (XObj (Mod innerEnv) _ _)) -> getEnv innerEnv ps
|
||||
Just _ -> error "Can't get non-env."
|
||||
Nothing -> error "Can't get env."
|
||||
-- | The value environment
|
||||
instance Environment Env where
|
||||
inj = id
|
||||
prj = id
|
||||
update e (Binder meta (XObj (Mod _ et) i t)) = Right (Binder meta (XObj (Mod e et) i t))
|
||||
update _ _ = Left NoReplaceInNonModule
|
||||
modality _ = Values
|
||||
|
||||
contextEnv :: Context -> Env
|
||||
contextEnv Context {contextInternalEnv = Just e} = e
|
||||
contextEnv Context {contextGlobalEnv = e, contextPath = p} = getEnv e p
|
||||
-- | The type environment
|
||||
instance Environment TypeEnv where
|
||||
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
|
||||
envIsExternal env =
|
||||
case envMode env of
|
||||
--------------------------------------------------------------------------------
|
||||
-- Misc. Environment utilities
|
||||
|
||||
-- | 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
|
||||
InternalEnv -> False
|
||||
RecursionEnv -> True
|
||||
|
||||
envReplaceBinding :: SymPath -> Binder -> Env -> Env
|
||||
envReplaceBinding s@(SymPath [] name) binder env =
|
||||
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)}))
|
||||
--------------------------------------------------------------------------------
|
||||
-- Binding Utilities
|
||||
|
||||
envBindingNames :: Env -> [String]
|
||||
envBindingNames = concatMap select . envBindings
|
||||
-- | Get a list of all the names of bindings in an environment that aren't
|
||||
-- hidden or private.
|
||||
envPublicBindingNames :: Environment e => e -> [String]
|
||||
envPublicBindingNames e = concatMap select (Map.toList (binders e))
|
||||
where
|
||||
select :: Binder -> [String]
|
||||
select (Binder _ (XObj (Mod m) _ _)) = envBindingNames m
|
||||
select (Binder _ obj) = [getName obj]
|
||||
|
||||
envPublicBindingNames :: Env -> [String]
|
||||
envPublicBindingNames = concatMap select . envBindings
|
||||
where
|
||||
select :: Binder -> [String]
|
||||
select (Binder _ (XObj (Mod m) _ _)) = envPublicBindingNames m
|
||||
select (Binder meta obj) =
|
||||
if metaIsTrue meta "private" || metaIsTrue meta "hidden"
|
||||
then []
|
||||
else [getName obj]
|
||||
select :: (String, Binder) -> [String]
|
||||
select (name, binder) =
|
||||
case (nextEnv (modality e) binder) of
|
||||
Left _ ->
|
||||
if metaIsTrue (binderMeta binder) "private" || metaIsTrue (binderMeta binder) "hidden"
|
||||
then []
|
||||
else [name]
|
||||
Right e' -> envPublicBindingNames e'
|
||||
|
||||
-- | 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 =
|
||||
concatMap finder (envBindings env)
|
||||
findAllGlobalVariables e =
|
||||
foldl' finder [] (Map.elems (binders e))
|
||||
where
|
||||
finder :: Binder -> [Binder]
|
||||
finder def@(Binder _ (XObj (Lst (XObj Def _ _ : _)) _ _)) =
|
||||
[def]
|
||||
finder (Binder _ (XObj (Mod innerEnv) _ _)) =
|
||||
findAllGlobalVariables innerEnv
|
||||
finder _ =
|
||||
[]
|
||||
finder :: [Binder] -> Binder -> [Binder]
|
||||
finder acc (Binder _ (XObj (Mod ev _) _ _)) = acc ++ (findAllGlobalVariables (inj ev))
|
||||
finder acc def@(Binder _ (XObj (Lst (XObj Def _ _ : _)) _ _)) = (def : acc)
|
||||
finder acc _ = acc
|
||||
|
126
src/Eval.hs
126
src/Eval.hs
@ -8,17 +8,17 @@ import Context
|
||||
import Control.Applicative
|
||||
import Control.Exception
|
||||
import Control.Monad.State
|
||||
import Data.Either (fromRight)
|
||||
import Data.Foldable (foldlM, foldrM)
|
||||
import Data.List (foldl', intercalate, isSuffixOf)
|
||||
import Data.List.Split (splitOn, splitWhen)
|
||||
import Data.Maybe (fromJust, fromMaybe, isJust)
|
||||
import Emit
|
||||
import Env
|
||||
import qualified Env as E
|
||||
import EvalError
|
||||
import Expand
|
||||
import Infer
|
||||
import Info
|
||||
import Lookup
|
||||
import qualified Map
|
||||
import qualified Meta
|
||||
import Obj
|
||||
@ -81,9 +81,10 @@ eval ctx xobj@(XObj o info ty) preference resolver =
|
||||
then pure (ctx, Left (HasStaticCall xobj info))
|
||||
else pure v
|
||||
checkStatic v = pure v
|
||||
-- all else failed, error.
|
||||
unwrapLookup =
|
||||
fromMaybe
|
||||
(throwErr (SymbolNotFound spath) ctx info) -- all else failed, error.
|
||||
(throwErr (SymbolNotFound spath) ctx info)
|
||||
tryAllLookups =
|
||||
( case preference of
|
||||
PreferDynamic -> tryDynamicLookup
|
||||
@ -91,19 +92,25 @@ eval ctx xobj@(XObj o info ty) preference resolver =
|
||||
)
|
||||
<|> (if null p then tryInternalLookup spath else tryLookup spath)
|
||||
tryDynamicLookup =
|
||||
lookupBinder (SymPath ("Dynamic" : p) n) (contextGlobalEnv ctx)
|
||||
>>= \(Binder _ found) -> pure (ctx, Right (resolveDef found))
|
||||
tryInternalLookup path =
|
||||
( contextInternalEnv ctx
|
||||
>>= lookupBinder path
|
||||
( maybeId (E.searchValueBinder (contextGlobalEnv ctx) (SymPath ("Dynamic" : p) n))
|
||||
>>= \(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 =
|
||||
( lookupBinder path (contextGlobalEnv ctx)
|
||||
( maybeId (E.searchValueBinder (contextGlobalEnv ctx) path)
|
||||
>>= \(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))
|
||||
)
|
||||
<|> ( foldl
|
||||
@ -111,7 +118,7 @@ eval ctx xobj@(XObj o info ty) preference resolver =
|
||||
Nothing
|
||||
( map
|
||||
( \(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
|
||||
)
|
||||
(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
|
||||
case res of
|
||||
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
|
||||
[f@(XObj Fn {} _ _), args@(XObj (Arr a) _ _), body] -> do
|
||||
(newCtx, expanded) <- macroExpand ctx body
|
||||
@ -446,7 +453,7 @@ macroExpand ctx xobj =
|
||||
|
||||
apply :: Context -> XObj -> [XObj] -> [XObj] -> IO (Context, Either EvalError XObj)
|
||||
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
|
||||
in case splitWhen (":rest" ==) allParams of
|
||||
[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' =
|
||||
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
|
||||
(zip proper (take n args))
|
||||
insideEnv'' =
|
||||
if null rest
|
||||
then insideEnv'
|
||||
else
|
||||
extendEnv
|
||||
insideEnv'
|
||||
(head rest)
|
||||
(XObj (Lst (drop n args)) Nothing Nothing)
|
||||
(c, r) <- evalDynamic ResolveLocal (replaceInternalEnv ctx insideEnv'') body
|
||||
fromRight
|
||||
(error "couldn't insert into inside env")
|
||||
( E.insertX
|
||||
insideEnv'
|
||||
(SymPath [] (head rest))
|
||||
(XObj (Lst (drop n args)) Nothing Nothing)
|
||||
)
|
||||
(c, r) <- (evalDynamic ResolveLocal (replaceInternalEnv ctx insideEnv'') body)
|
||||
pure (c {contextInternalEnv = internal}, r)
|
||||
|
||||
-- | 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 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
|
||||
env' = env {envUseModules = Set.insert path useThese}
|
||||
ctx' = replaceGlobalEnv ctx env'
|
||||
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'.
|
||||
ctxAfter' = replaceGlobalEnv ctx (envAfter {envUseModules = useThese})
|
||||
pure (ctxAfter', dynamicNil)
|
||||
@ -645,7 +655,7 @@ getSigFromDefnOrDef ctx xobj =
|
||||
fullPath = case path of
|
||||
(SymPath [] _) -> consPath pathStrings path
|
||||
(SymPath _ _) -> path
|
||||
metaData = lookupMeta fullPath globalEnv
|
||||
metaData = either (const emptyMeta) id (E.lookupMeta globalEnv fullPath)
|
||||
in case Meta.get "sig" metaData of
|
||||
Just foundSignature ->
|
||||
case xobjToTy foundSignature of
|
||||
@ -683,39 +693,45 @@ annotateWithinContext ctx xobj = do
|
||||
Right ok -> pure (ctx, Right ok)
|
||||
|
||||
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!
|
||||
-- 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.
|
||||
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
|
||||
>>= \(newCtx, result) ->
|
||||
case result of
|
||||
Left err -> pure (newCtx, Left err)
|
||||
Right _ -> pure (popModulePath (newCtx {contextInternalEnv = envParent =<< contextInternalEnv newCtx}), dynamicNil)
|
||||
let updater c = (c {contextInternalEnv = (E.parent =<< contextInternalEnv c)})
|
||||
in case result of
|
||||
Left err -> pure (newCtx, Left err)
|
||||
Right _ -> pure (updater (popModulePath newCtx), dynamicNil)
|
||||
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 _ (XObj (Mod innerEnv) _ _)) =
|
||||
let ctx' =
|
||||
ctx
|
||||
{ contextInternalEnv = Just innerEnv {envParent = i},
|
||||
contextPath = contextPath ctx ++ [moduleName]
|
||||
}
|
||||
in pure (ctx', dynamicNil)
|
||||
updateExistingModule (Binder _ (XObj (Mod innerEnv _) _ _)) =
|
||||
let updateContext =
|
||||
replacePath' (contextPath ctx ++ [moduleName])
|
||||
. replaceInternalEnv' (innerEnv {envParent = i})
|
||||
in pure (updateContext ctx, dynamicNil)
|
||||
updateExistingModule (Binder meta (XObj (Lst [XObj MetaStub _ _, _]) _ _)) =
|
||||
defineNewModule meta
|
||||
updateExistingModule _ =
|
||||
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 meta =
|
||||
pure (ctx', dynamicNil)
|
||||
pure (fromRight ctx (updater ctx), dynamicNil)
|
||||
where
|
||||
moduleEnv = Env (Map.fromList []) (Just (getEnv env pathStrings)) (Just moduleName) Set.empty ExternalEnv 0
|
||||
newModule = XObj (Mod moduleEnv) (xobjInfo xobj) (Just ModuleTy)
|
||||
updatedGlobalEnv = envInsertAt env (SymPath pathStrings moduleName) (Binder meta newModule)
|
||||
-- The parent of the internal env needs to be set to i here for contextual `use` calls to work.
|
||||
-- In theory this shouldn't be necessary; but for now it is.
|
||||
ctx' = ctx {contextGlobalEnv = updatedGlobalEnv, contextInternalEnv = Just moduleEnv {envParent = i}, contextPath = contextPath ctx ++ [moduleName]}
|
||||
moduleDefs = E.new (Just (fromRight env (E.getInnerEnv env pathStrings))) (Just moduleName)
|
||||
moduleTypes = E.new (Just tenv) (Just moduleName)
|
||||
newModule = XObj (Mod moduleDefs moduleTypes) (xobjInfo xobj) (Just ModuleTy)
|
||||
updater = \c ->
|
||||
insertInGlobalEnv' (markQualified (SymPath pathStrings moduleName)) (Binder meta newModule) c
|
||||
>>= 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, Left e) = pure (context, Left e)
|
||||
defineModuleBindings (context, _) =
|
||||
@ -725,7 +741,7 @@ primitiveDefmodule xobj ctx@(Context env i _ pathStrings _ _ _ _) (XObj (Sym (Sy
|
||||
step (ctx', Right _) expressions =
|
||||
macroExpand ctx' expressions
|
||||
>>= \(ctx'', res) -> case res of
|
||||
Left _ -> pure (ctx'', res)
|
||||
Left err -> pure (ctx'', Left err)
|
||||
Right r -> evalDynamic ResolveLocal ctx'' r
|
||||
primitiveDefmodule _ ctx (x : _) =
|
||||
pure (throwErr (DefmoduleContainsNonSymbol x) ctx (xobjInfo x))
|
||||
@ -1013,21 +1029,21 @@ primitiveDefdynamic _ ctx notName _ =
|
||||
pure (throwErr (DefnDynamicInvalidName notName) ctx (xobjInfo notName))
|
||||
|
||||
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 =
|
||||
contextInternalEnv ctx
|
||||
maybe (Left "") Right (contextInternalEnv ctx)
|
||||
>>= \e ->
|
||||
lookupBinder path e
|
||||
unwrapErr (E.searchValueBinder e path)
|
||||
>>= \binder -> pure (binder, setInternal, e)
|
||||
lookupGlobal =
|
||||
Just (contextGlobalEnv ctx)
|
||||
Right (contextGlobalEnv ctx)
|
||||
>>= \e ->
|
||||
lookupBinder path e
|
||||
unwrapErr (E.searchValueBinder e path)
|
||||
>>= \binder -> pure (binder, setGlobal, e)
|
||||
in maybe
|
||||
(pure $ (throwErr (SetVarNotFound orig) ctx (xobjInfo orig)))
|
||||
in either
|
||||
((const (pure $ (throwErr (SetVarNotFound orig) ctx (xobjInfo orig)))))
|
||||
(\(binder', setter', env') -> evalAndSet binder' setter' env')
|
||||
(lookupInternal <|> lookupGlobal)
|
||||
(lookupInternal <> lookupGlobal)
|
||||
where
|
||||
evalAndSet :: Binder -> (Context -> Env -> Either EvalError XObj -> Binder -> IO (Context, Either EvalError XObj)) -> Env -> IO (Context, Either EvalError XObj)
|
||||
evalAndSet binder setter env =
|
||||
@ -1051,7 +1067,7 @@ specialCommandSet ctx [orig@(XObj (Sym path@(SymPath _ n) _) _ _), val] =
|
||||
setInternal ctx' env value binder =
|
||||
pure $ either (failure ctx' orig) (success ctx') value
|
||||
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, _] =
|
||||
pure (throwErr (SetInvalidVarName notName) ctx (xobjInfo notName))
|
||||
specialCommandSet ctx args =
|
||||
@ -1080,14 +1096,14 @@ typeCheckValueAgainstBinder ctx val binder = do
|
||||
-- assigns an appropriate type to the variable.
|
||||
-- Returns a new environment containing the assignment.
|
||||
setStaticOrDynamicVar :: SymPath -> Env -> Binder -> XObj -> Env
|
||||
setStaticOrDynamicVar path env binder value =
|
||||
setStaticOrDynamicVar path@(SymPath _ name) env binder value =
|
||||
case binder of
|
||||
(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 : _)) _ _)) ->
|
||||
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)) ->
|
||||
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.
|
||||
-- TODO: Return an either here to propagate error.
|
||||
_ -> env
|
||||
|
@ -4,7 +4,6 @@ import Control.Monad.State (State, evalState, get, put)
|
||||
import Data.Foldable (foldlM)
|
||||
import Env
|
||||
import Info
|
||||
import Lookup
|
||||
import Obj
|
||||
import TypeError
|
||||
import Types
|
||||
@ -219,7 +218,7 @@ expand eval ctx xobj =
|
||||
("`ref` takes a single argument, but I got `" ++ pretty xobj ++ "`.")
|
||||
(xobjInfo xobj)
|
||||
)
|
||||
XObj (Mod modEnv) _ _ : args ->
|
||||
XObj (Mod modEnv _) _ _ : args ->
|
||||
let pathToModule = pathToEnv modEnv
|
||||
implicitInit = XObj (Sym (SymPath pathToModule "init") Symbol) i t
|
||||
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."
|
||||
expandSymbol :: XObj -> IO (Context, Either EvalError XObj)
|
||||
expandSymbol sym@(XObj (Sym path _) _ _) =
|
||||
case lookupBinder path (contextEnv ctx) of
|
||||
Just (Binder meta (XObj (Lst (XObj (External _) _ _ : _)) _ _)) -> isPrivate meta xobj
|
||||
Just (Binder meta (XObj (Lst (XObj (Instantiate _) _ _ : _)) _ _)) -> isPrivate meta xobj
|
||||
Just (Binder meta (XObj (Lst (XObj (Deftemplate _) _ _ : _)) _ _)) -> isPrivate meta xobj
|
||||
Just (Binder meta (XObj (Lst (XObj (Defn _) _ _ : _)) _ _)) -> isPrivate meta xobj
|
||||
Just (Binder meta (XObj (Lst (XObj Def _ _ : _)) _ _)) -> isPrivate meta xobj
|
||||
Just (Binder meta (XObj (Lst (XObj (Defalias _) _ _ : _)) _ _)) -> isPrivate meta xobj
|
||||
Just (Binder meta found) -> isPrivate meta found -- use the found value
|
||||
Nothing -> pure (ctx, Right xobj) -- symbols that are not found are left as-is
|
||||
case searchValueBinder (contextEnv ctx) path of
|
||||
Right (Binder meta (XObj (Lst (XObj (External _) _ _ : _)) _ _)) -> isPrivate meta xobj
|
||||
Right (Binder meta (XObj (Lst (XObj (Instantiate _) _ _ : _)) _ _)) -> isPrivate meta xobj
|
||||
Right (Binder meta (XObj (Lst (XObj (Deftemplate _) _ _ : _)) _ _)) -> isPrivate meta xobj
|
||||
Right (Binder meta (XObj (Lst (XObj (Defn _) _ _ : _)) _ _)) -> isPrivate meta xobj
|
||||
Right (Binder meta (XObj (Lst (XObj Def _ _ : _)) _ _)) -> isPrivate meta xobj
|
||||
Right (Binder meta (XObj (Lst (XObj (Defalias _) _ _ : _)) _ _)) -> isPrivate meta xobj
|
||||
Right (Binder meta found) -> isPrivate meta found -- use the found value
|
||||
Left _ -> pure (ctx, Right xobj) -- symbols that are not found are left as-is
|
||||
where
|
||||
isPrivate m x =
|
||||
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)
|
||||
(xobjInfo x)
|
||||
(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 ..]
|
||||
headConstraint = Constraint headTy t headObj (genObj x 1) xobj OrdArrHead
|
||||
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)
|
||||
(xobjInfo x)
|
||||
(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 ..]
|
||||
headConstraint = Constraint headTy t headObj (genObj x 1) xobj OrdArrHead
|
||||
pure (headConstraint : insideExprConstraints ++ betweenExprConstraints)
|
||||
|
@ -1,9 +1,8 @@
|
||||
module InitialTypes where
|
||||
|
||||
import Control.Monad.State
|
||||
import Env
|
||||
import Env as E
|
||||
import Info
|
||||
import Lookup
|
||||
import qualified Map
|
||||
import Obj
|
||||
import qualified Set
|
||||
@ -99,7 +98,7 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
|
||||
If -> pure (Left (InvalidObj If xobj))
|
||||
While -> pure (Left (InvalidObj While 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@(External _) -> 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 _ (':' : _) -> pure (Left (LeadingColon xobj))
|
||||
_ ->
|
||||
case lookupInEnv symPath env of
|
||||
Just (foundEnv, binder) ->
|
||||
case E.searchValue env symPath of
|
||||
Right (foundEnv, binder) ->
|
||||
case xobjTy (binderXObj binder) of
|
||||
-- Don't rename internal symbols like parameters etc!
|
||||
Just theType
|
||||
@ -138,7 +137,7 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
|
||||
pure (Right (xobj {xobjTy = Just renamed}))
|
||||
| otherwise -> pure (Right (xobj {xobjTy = Just theType}))
|
||||
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 _ xobj@(XObj (MultiSym _ _) _ _) _ =
|
||||
do
|
||||
@ -148,10 +147,10 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
|
||||
visitInterfaceSym :: Env -> XObj -> State Integer (Either TypeError XObj)
|
||||
visitInterfaceSym _ xobj@(XObj (InterfaceSym name) _ _) =
|
||||
do
|
||||
freshTy <- case lookupBinder (SymPath [] name) (getTypeEnv typeEnv) of
|
||||
Just (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)
|
||||
Nothing -> genVarTy
|
||||
freshTy <- case getTypeBinder typeEnv name of
|
||||
Right (Binder _ (XObj (Lst [XObj (Interface interfaceSignature _) _ _, _]) _ _)) -> renameVarTys interfaceSignature
|
||||
Right (Binder _ x) -> error ("A non-interface named '" ++ name ++ "' was found in the type environment: " ++ pretty x)
|
||||
Left _ -> genVarTy
|
||||
pure (Right xobj {xobjTy = Just freshTy})
|
||||
visitInterfaceSym _ _ = error "visitinterfacesym"
|
||||
visitArray :: Env -> XObj -> State Integer (Either TypeError XObj)
|
||||
@ -161,7 +160,7 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
|
||||
arrayVarTy <- genVarTy
|
||||
pure $ do
|
||||
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."
|
||||
visitStaticArray :: Env -> XObj -> State Integer (Either TypeError XObj)
|
||||
visitStaticArray env (XObj (StaticArr xobjs) i _) =
|
||||
@ -171,7 +170,7 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
|
||||
lt <- genVarTy
|
||||
pure $ do
|
||||
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."
|
||||
visitDictionary :: Env -> XObj -> State Integer (Either TypeError XObj)
|
||||
visitDictionary env (XObj (Dict xobjs) i _) =
|
||||
@ -180,7 +179,7 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
|
||||
arrayVarTy <- genVarTy
|
||||
pure $ do
|
||||
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."
|
||||
getTys env argList =
|
||||
do
|
||||
@ -198,7 +197,7 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
|
||||
let funcTy = Just (FuncTy argTypes returnType StaticLifetimeTy)
|
||||
typedNameSymbol = nameSymbol {xobjTy = funcTy}
|
||||
-- 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
|
||||
visitedArgs <- mapM (visit envWithSelf) argList
|
||||
pure $ do
|
||||
@ -440,15 +439,18 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
|
||||
(Sym (SymPath _ name) _) ->
|
||||
do
|
||||
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)))
|
||||
extendEnvWithParamList :: Env -> [XObj] -> State Integer Env
|
||||
extendEnvWithParamList env xobjs =
|
||||
do
|
||||
binders <- mapM createBinderForParam xobjs
|
||||
binders' <- mapM createBinderForParam xobjs
|
||||
pure
|
||||
Env
|
||||
{ envBindings = Map.fromList binders,
|
||||
{ envBindings = Map.fromList binders',
|
||||
envParent = Just env,
|
||||
envModuleName = Nothing,
|
||||
envUseModules = Set.empty,
|
||||
@ -468,10 +470,10 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
|
||||
extendEnvWithCaseMatch :: Env -> XObj -> State Integer Env
|
||||
extendEnvWithCaseMatch env caseRoot =
|
||||
do
|
||||
binders <- createBindersForCaseVariable caseRoot
|
||||
binders' <- createBindersForCaseVariable caseRoot
|
||||
pure
|
||||
Env
|
||||
{ envBindings = Map.fromList binders,
|
||||
{ envBindings = Map.fromList binders',
|
||||
envParent = Just env,
|
||||
envModuleName = Nothing,
|
||||
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 (InterfaceSym name) _ _) = createBinderInternal xobj name
|
||||
createBindersForCaseVariable (XObj (Lst lst) _ _) = do
|
||||
binders <- mapM createBindersForCaseVariable lst
|
||||
pure (concat binders)
|
||||
binders' <- mapM createBindersForCaseVariable lst
|
||||
pure (concat binders')
|
||||
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
|
||||
createBinderInternal :: XObj -> String -> State Integer [(String, Binder)]
|
||||
|
@ -14,12 +14,13 @@ where
|
||||
|
||||
import ColorText
|
||||
import Constraints
|
||||
import Context
|
||||
import Data.Either (fromRight, rights)
|
||||
import Data.List (delete, deleteBy, foldl')
|
||||
import Data.Maybe (fromMaybe, mapMaybe)
|
||||
import Env
|
||||
import Lookup
|
||||
import qualified Env
|
||||
import qualified Meta
|
||||
import Obj
|
||||
import qualified Qualify
|
||||
import Types
|
||||
import Util
|
||||
|
||||
@ -67,7 +68,7 @@ instance Show InterfaceError where
|
||||
-- | Get the first path of an interface implementation that matches a given type signature
|
||||
getFirstMatchingImplementation :: Context -> [SymPath] -> Ty -> Maybe SymPath
|
||||
getFirstMatchingImplementation ctx paths ty =
|
||||
case filter predicate (mapMaybe (`lookupBinder` global) paths) of
|
||||
case filter predicate (rights (map (global `Env.searchValueBinder`) paths)) of
|
||||
[] -> Nothing
|
||||
(x : _) -> Just ((getPath . binderXObj) x)
|
||||
where
|
||||
@ -77,53 +78,51 @@ getFirstMatchingImplementation ctx paths ty =
|
||||
-- | Remove an interface from a binder's list of implemented interfaces
|
||||
removeInterfaceFromImplements :: SymPath -> XObj -> Context -> Context
|
||||
removeInterfaceFromImplements oldImplPath interface ctx =
|
||||
fromMaybe
|
||||
fromRight
|
||||
ctx
|
||||
( lookupBinder oldImplPath (contextGlobalEnv ctx)
|
||||
( lookupBinderInGlobalEnv ctx (Qualify.markQualified oldImplPath)
|
||||
>>= \binder ->
|
||||
Meta.getBinderMetaValue "implements" binder
|
||||
>>= ( \x ->
|
||||
case x of
|
||||
(XObj (Lst impls) i t) ->
|
||||
pure $ Meta.updateBinderMeta binder "implements" (XObj (Lst (deleteBy matchPath interface impls)) i t)
|
||||
_ -> Nothing
|
||||
)
|
||||
>>= (\b -> pure $ ctx {contextGlobalEnv = envInsertAt (contextGlobalEnv ctx) oldImplPath b})
|
||||
pure
|
||||
( case Meta.getBinderMetaValue "implements" binder of
|
||||
Just (XObj (Lst impls) i t) -> Meta.updateBinderMeta binder "implements" (XObj (Lst (deleteBy matchPath interface impls)) i t)
|
||||
_ -> binder
|
||||
)
|
||||
>>= insertInGlobalEnv ctx (Qualify.markQualified oldImplPath)
|
||||
)
|
||||
where
|
||||
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.
|
||||
-- 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 =
|
||||
case interface of
|
||||
Binder _ (XObj (Lst [inter@(XObj (Interface interfaceSignature paths) ii it), isym]) i t) ->
|
||||
if checkKinds interfaceSignature definitionSignature
|
||||
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
|
||||
Nothing -> (updatedCtx, Nothing)
|
||||
Just x ->
|
||||
if x == implPath
|
||||
then (updatedCtx, Nothing)
|
||||
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
|
||||
qpath = (Qualify.markQualified (SymPath [] name))
|
||||
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
|
||||
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
|
||||
implPath = getBinderPath implementation
|
||||
typeEnv = getTypeEnv (contextTypeEnv ctx)
|
||||
ipath@(SymPath _ name) = getBinderPath interface
|
||||
|
||||
-- | Given a binder and an interface path, ensure that the form is
|
||||
-- registered with the interface.
|
||||
registerInInterface :: Context -> Binder -> Binder -> (Context, Maybe InterfaceError)
|
||||
registerInInterface :: Context -> Binder -> Binder -> (Either ContextError Context, Maybe InterfaceError)
|
||||
registerInInterface ctx implementation interface =
|
||||
case binderXObj implementation of
|
||||
XObj (Lst [XObj (Defn _) _ _, _, _, _]) _ (Just t) ->
|
||||
@ -141,26 +140,26 @@ registerInInterface ctx implementation interface =
|
||||
-- And instantiated/auto-derived type functions! (e.g. Pair.a)
|
||||
XObj (Lst [XObj (Instantiate _) _ _, _]) _ (Just t) ->
|
||||
registerInInterfaceIfNeeded ctx implementation interface t
|
||||
_ -> (ctx, Nothing)
|
||||
_ -> (Right ctx, Nothing)
|
||||
|
||||
-- | For forms that were declared as implementations of interfaces that didn't exist,
|
||||
-- retroactively register those forms with the interface once its defined.
|
||||
retroactivelyRegisterInInterface :: Context -> Binder -> Context
|
||||
retroactivelyRegisterInInterface :: Context -> Binder -> Either ContextError Context
|
||||
retroactivelyRegisterInInterface ctx interface =
|
||||
-- TODO: Propagate error
|
||||
maybe resultCtx (error . show) err
|
||||
where
|
||||
env = contextGlobalEnv ctx
|
||||
impls = lookupMany Everywhere lookupImplementations (getPath (binderXObj interface)) env
|
||||
(resultCtx, err) = foldl' (\(context, _) binder -> registerInInterface context binder interface) (ctx, Nothing) impls
|
||||
impls = concat (rights (fmap ((flip Env.findImplementations) (getPath (binderXObj interface))) (env : (Env.lookupChildren env))))
|
||||
(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,
|
||||
-- | e.g. Is "delete" implemented for `(Fn [String] ())` ?
|
||||
interfaceImplementedForTy :: TypeEnv -> Env -> String -> Ty -> Bool
|
||||
interfaceImplementedForTy (TypeEnv typeEnv) globalEnv interfaceName matchingTy =
|
||||
case lookupBinder (SymPath [] interfaceName) typeEnv of
|
||||
Just (Binder _ (XObj (Lst (XObj (Interface _ paths) _ _ : _)) _ _)) ->
|
||||
let lookupType path = forceTy . binderXObj <$> lookupBinder path globalEnv
|
||||
matches = filter (areUnifiable matchingTy) (mapMaybe lookupType paths)
|
||||
interfaceImplementedForTy typeEnv globalEnv interfaceName matchingTy =
|
||||
case Env.getTypeBinder typeEnv interfaceName of
|
||||
Right (Binder _ (XObj (Lst (XObj (Interface _ paths) _ _ : _)) _ _)) ->
|
||||
let lookupType' path = forceTy . binderXObj <$> (Env.searchValueBinder globalEnv path)
|
||||
matches = filter (areUnifiable matchingTy) (rights (map lookupType' paths))
|
||||
in not . null $ matches
|
||||
_ -> 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 GeneralizedNewtypeDeriving #-}
|
||||
|
||||
@ -18,7 +19,7 @@ fromList :: Ord k => [(k, v)] -> Map k v
|
||||
fromList = Map . M.fromList
|
||||
|
||||
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 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 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
|
||||
| If
|
||||
| Match MatchMode
|
||||
| Mod Env
|
||||
| Mod Env TypeEnv
|
||||
| Deftype Ty
|
||||
| DefSumtype Ty
|
||||
| With
|
||||
@ -342,7 +342,7 @@ getBinderDescription (XObj (Lst (XObj MetaStub _ _ : XObj (Sym _ _) _ _ : _)) _
|
||||
getBinderDescription (XObj (Lst (XObj (Deftype _) _ _ : XObj (Sym _ _) _ _ : _)) _ _) = "deftype"
|
||||
getBinderDescription (XObj (Lst (XObj (DefSumtype _) _ _ : XObj (Sym _ _) _ _ : _)) _ _) = "deftype"
|
||||
getBinderDescription (XObj (Lst (XObj (Interface _ _) _ _ : XObj (Sym _ _) _ _ : _)) _ _) = "interface"
|
||||
getBinderDescription (XObj (Mod _) _ _) = "module"
|
||||
getBinderDescription (XObj (Mod _ _) _ _) = "module"
|
||||
getBinderDescription b = error ("Unhandled binder: " ++ show b)
|
||||
|
||||
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 MetaStub _ _ : 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 (Command _) _ _ : XObj (Sym path _) _ _ : _)) _ _) = path
|
||||
getPath (XObj (Lst (XObj (Primitive _) _ _ : XObj (Sym path _) _ _ : _)) _ _) = path
|
||||
@ -449,7 +449,7 @@ pretty = visit 0
|
||||
Do -> "do"
|
||||
Let -> "let"
|
||||
LocalDef -> "local-binding"
|
||||
Mod env -> fromMaybe "module" (envModuleName env)
|
||||
Mod env _ -> fromMaybe "module" (envModuleName env)
|
||||
Deftype _ -> "deftype"
|
||||
DefSumtype _ -> "deftype"
|
||||
Deftemplate _ -> "deftemplate"
|
||||
@ -515,7 +515,7 @@ prettyUpTo lim xobj =
|
||||
Do -> ""
|
||||
Let -> ""
|
||||
LocalDef -> ""
|
||||
Mod _ -> ""
|
||||
Mod _ _ -> ""
|
||||
Deftype _ -> ""
|
||||
DefSumtype _ -> ""
|
||||
Deftemplate _ -> ""
|
||||
@ -643,10 +643,12 @@ forceShowBinder :: Binder -> String
|
||||
forceShowBinder binder = showBinderIndented 0 True (getName (binderXObj binder), binder)
|
||||
|
||||
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"
|
||||
++ prettyEnvironmentIndented (indent + 4) env
|
||||
++ "\n"
|
||||
++ prettyEnvironmentIndented (indent + 4) (getTypeEnv tenv)
|
||||
++ "\n"
|
||||
++ replicate indent ' '
|
||||
++ "}"
|
||||
showBinderIndented indent _ (name, Binder _ (XObj (Lst [XObj (Interface t paths) _ _, _]) _ _)) =
|
||||
@ -717,7 +719,7 @@ instance Hashable ClosureContext
|
||||
instance Eq ClosureContext where
|
||||
_ == _ = True
|
||||
|
||||
newtype TypeEnv = TypeEnv {getTypeEnv :: Env} deriving (Generic)
|
||||
newtype TypeEnv = TypeEnv {getTypeEnv :: Env} deriving (Generic, Eq)
|
||||
|
||||
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 _ "Bool") _) _ _) = Just BoolTy
|
||||
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)
|
||||
| otherwise = Just (StructTy (ConcreteNameTy (createStructName prefixes s)) [])
|
||||
| otherwise = Just (StructTy (ConcreteNameTy spath) [])
|
||||
xobjToTy (XObj (Lst [XObj (Sym (SymPath _ "Ptr") _) _ _, innerTy]) _ _) =
|
||||
do
|
||||
okInnerTy <- xobjToTy innerTy
|
||||
@ -945,10 +947,10 @@ defineFunctionTypeAlias :: Ty -> XObj
|
||||
defineFunctionTypeAlias aliasTy = defineTypeAlias (tyToC aliasTy) aliasTy
|
||||
|
||||
defineArrayTypeAlias :: Ty -> XObj
|
||||
defineArrayTypeAlias t = defineTypeAlias (tyToC t) (StructTy (ConcreteNameTy "Array") [])
|
||||
defineArrayTypeAlias t = defineTypeAlias (tyToC t) (StructTy (ConcreteNameTy (SymPath [] "Array")) [])
|
||||
|
||||
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
|
||||
|
@ -1,24 +1,30 @@
|
||||
module Polymorphism where
|
||||
module Polymorphism
|
||||
( nameOfPolymorphicFunction,
|
||||
)
|
||||
where
|
||||
|
||||
import Lookup
|
||||
import Env as E
|
||||
import Obj
|
||||
import Types
|
||||
|
||||
-- | Calculate the full, mangled name of a concretized polymorphic function.
|
||||
-- | 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
|
||||
-- | and similar for internal use.
|
||||
|
||||
-- | TODO: Environments are passed in different order here!!!
|
||||
-- For example, The 'id' in "(id 3)" will become 'id__int'.
|
||||
--
|
||||
-- This function uses findPoly, which gives it access to *all* possible
|
||||
-- environments in the given input environment (children, (modules) parents,
|
||||
-- and use modules). This allows it to derive the correct name for functions
|
||||
-- that may be defined in a different environment.
|
||||
--
|
||||
-- TODO: Environments are passed in different order here!!!
|
||||
nameOfPolymorphicFunction :: TypeEnv -> Env -> Ty -> String -> Maybe SymPath
|
||||
nameOfPolymorphicFunction _ env functionType functionName =
|
||||
let foundBinders = multiLookupEverywhere functionName env
|
||||
in case filter ((\(Just t') -> areUnifiable functionType t') . xobjTy . binderXObj . snd) foundBinders of
|
||||
[] -> Nothing
|
||||
[(_, Binder _ (XObj (Lst (XObj (External (Just name)) _ _ : _)) _ _))] ->
|
||||
let foundBinder =
|
||||
(E.findPoly env functionName functionType)
|
||||
<> (E.findPoly (progenitor env) functionName functionType)
|
||||
in case foundBinder of
|
||||
Right (_, (Binder _ (XObj (Lst (XObj (External (Just name)) _ _ : _)) _ _))) ->
|
||||
Just (SymPath [] name)
|
||||
[(_, Binder _ single)] ->
|
||||
Right (_, (Binder _ single)) ->
|
||||
let Just t' = xobjTy single
|
||||
(SymPath pathStrings name) = getPath single
|
||||
suffix = polymorphicSuffix t' functionType
|
||||
|
@ -11,6 +11,14 @@ data PrimitiveError
|
||||
| ForewardImplementsMeta
|
||||
| RegisterTypeError
|
||||
| SymbolNotFoundError SymPath
|
||||
| BadDeftypeMembers
|
||||
| QualifiedTypeMember [XObj]
|
||||
| InvalidTypeName XObj
|
||||
| InvalidTypeVariables XObj
|
||||
| MetaSetFailed XObj String
|
||||
| StructNotFound XObj
|
||||
| NonTypeInTypeEnv SymPath XObj
|
||||
| InvalidSumtypeCase XObj
|
||||
|
||||
data PrimitiveWarning
|
||||
= NonExistentInterfaceWarning XObj
|
||||
@ -40,6 +48,32 @@ instance Show PrimitiveError where
|
||||
++ " (register-type Name c-name [field0 Type, ...]"
|
||||
show (SymbolNotFoundError 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
|
||||
show (NonExistentInterfaceWarning x) =
|
||||
|
@ -8,27 +8,26 @@ import Context
|
||||
import Control.Applicative
|
||||
import Control.Monad (foldM, unless, when)
|
||||
import Control.Monad.IO.Class (MonadIO, liftIO)
|
||||
import Data.Either (rights)
|
||||
import Data.Bifunctor
|
||||
import Data.Either (fromRight, rights)
|
||||
import Data.Functor ((<&>))
|
||||
import Data.List (foldl')
|
||||
import Data.Maybe (fromJust, fromMaybe, mapMaybe)
|
||||
import Data.Maybe (fromJust, fromMaybe)
|
||||
import Deftype
|
||||
import Emit
|
||||
import Env
|
||||
import Env (addUsePath, contextEnv, insert, lookupBinderEverywhere, lookupEverywhere, lookupMeta, searchValueBinder)
|
||||
import Infer
|
||||
import Info
|
||||
import Interfaces
|
||||
import Lookup
|
||||
import Managed
|
||||
import qualified Map
|
||||
import qualified Meta
|
||||
import Obj
|
||||
import PrimitiveError
|
||||
import Project
|
||||
import Qualify (Qualified (..), getQualifiedPath, markQualified, qualify, qualifyNull, qualifyPath, unqualify)
|
||||
import Qualify (Qualified (..), QualifiedPath, getQualifiedPath, markQualified, qualify, qualifyNull, qualifyPath, unqualify)
|
||||
import Reify
|
||||
import qualified Set
|
||||
import Sumtypes
|
||||
import SymPath
|
||||
import Template
|
||||
import ToTemplate
|
||||
import TypeError
|
||||
@ -122,10 +121,10 @@ primitiveImplements _ ctx x@(XObj (Sym interface@(SymPath _ _) _) _ _) (XObj (Sy
|
||||
do
|
||||
(maybeInterface, maybeImpl) <- pure (lookupInterface ctx interface, lookupBinderInGlobalEnv ctx qpath)
|
||||
case (maybeInterface, maybeImpl) of
|
||||
(_, Nothing) -> updateMeta (Meta.stub (contextualize path ctx)) ctx
|
||||
(Nothing, Just implBinder) ->
|
||||
(_, Left _) -> updateMeta (Meta.stub (contextualize path ctx)) ctx
|
||||
(Left _, Right implBinder) ->
|
||||
warn >> updateMeta implBinder ctx
|
||||
(Just interfaceBinder, Just implBinder) ->
|
||||
(Right interfaceBinder, Right implBinder) ->
|
||||
-- N.B. The found binding will be fully qualified!
|
||||
addToInterface interfaceBinder implBinder
|
||||
where
|
||||
@ -134,7 +133,7 @@ primitiveImplements _ ctx x@(XObj (Sym interface@(SymPath _ _) _) _ _) (XObj (Sy
|
||||
warn = emitWarning (show (NonExistentInterfaceWarning x))
|
||||
addToInterface :: Binder -> Binder -> IO (Context, Either EvalError XObj)
|
||||
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
|
||||
handleError :: Context -> Binder -> InterfaceError -> IO (Context, Either EvalError XObj)
|
||||
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))
|
||||
updateMeta :: Binder -> Context -> IO (Context, Either EvalError XObj)
|
||||
updateMeta binder context =
|
||||
pure (fromJust update, dynamicNil)
|
||||
pure (fromRight (error "Couldn't insert updated meta!!") (fromJust updater), dynamicNil)
|
||||
where
|
||||
update =
|
||||
updater =
|
||||
( ( Meta.getBinderMetaValue "implements" binder
|
||||
<&> updateImplementations binder
|
||||
)
|
||||
@ -178,20 +177,22 @@ define hidden ctx qualifiedXObj =
|
||||
freshBinder = toBinder annXObj
|
||||
qpath = getQualifiedPath qualifiedXObj
|
||||
defineInTypeEnv :: Binder -> IO Context
|
||||
defineInTypeEnv = pure . (insertInTypeEnv ctx qpath)
|
||||
defineInTypeEnv = pure . fromRight ctx . (insertTypeBinder ctx qpath)
|
||||
defineInGlobalEnv :: Binder -> IO Context
|
||||
defineInGlobalEnv newBinder =
|
||||
when (projectEchoC (contextProj ctx)) (putStrLn (toC All (Binder emptyMeta annXObj)))
|
||||
>> case (lookupBinderInGlobalEnv ctx qpath) of
|
||||
Nothing -> pure (insertInGlobalEnv ctx qpath newBinder)
|
||||
Just oldBinder -> redefineExistingBinder oldBinder newBinder
|
||||
Left _ -> pure (fromRight ctx (insertInGlobalEnv ctx qpath newBinder))
|
||||
Right oldBinder -> redefineExistingBinder oldBinder newBinder
|
||||
redefineExistingBinder :: Binder -> Binder -> IO Context
|
||||
redefineExistingBinder old@(Binder meta _) (Binder _ x) =
|
||||
do
|
||||
warnTypeChange old
|
||||
unless (isInstantiation (binderXObj old)) (warnTypeChange old)
|
||||
-- TODO: Merge meta more elegantly.
|
||||
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 =
|
||||
unless (areUnifiable (forceTy annXObj) previousType) warn
|
||||
@ -208,9 +209,9 @@ define hidden ctx qualifiedXObj =
|
||||
>>= \(XObj (Lst interfaces) _ _) -> pure (map Qualified interfaces)
|
||||
)
|
||||
>>= \maybeinterfaces ->
|
||||
pure (mapMaybe (lookupBinderInTypeEnv ctx . getQualifiedPath) (fromMaybe [] maybeinterfaces))
|
||||
pure (rights (fmap (lookupBinderInTypeEnv ctx . getQualifiedPath) (fromMaybe [] maybeinterfaces)))
|
||||
>>= \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
|
||||
Just e -> printError (contextExecMode ctx) (show e) >> pure ctx
|
||||
Nothing -> pure newCtx
|
||||
@ -233,13 +234,17 @@ primitiveRegisterType _ ctx [x@(XObj (Sym (SymPath [] t) _) _ _), members] =
|
||||
primitiveRegisterTypeWithFields ctx x t Nothing members
|
||||
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 ctx t override = do
|
||||
let path = SymPath [] t
|
||||
typeDefinition = XObj (Lst [XObj (ExternalType override) Nothing Nothing, XObj (Sym path Symbol) Nothing Nothing]) Nothing (Just TypeTy)
|
||||
-- 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 ctx x t override members =
|
||||
either
|
||||
@ -252,46 +257,47 @@ primitiveRegisterTypeWithFields ctx x t override members =
|
||||
do
|
||||
let typeDefinition = XObj (Lst [XObj (ExternalType override) Nothing Nothing, XObj (Sym path Symbol) Nothing Nothing]) Nothing (Just TypeTy)
|
||||
path' = (qualifyPath ctx (SymPath [] typeModuleName))
|
||||
update = insertInTypeEnv' path' (toBinder typeDefinition) . insertInGlobalEnv' path' (toBinder typeModuleXObj)
|
||||
ctx' = update ctx
|
||||
update = \c -> insertInGlobalEnv' path' (toBinder typeModuleXObj) c >>= insertTypeBinder' path' (toBinder typeDefinition)
|
||||
Right ctx' = update ctx
|
||||
-- TODO: Another case where define does not get formally qualified deps!
|
||||
contextWithDefs <- liftIO $ foldM (define True) ctx' (map Qualified deps)
|
||||
pure (contextWithDefs, dynamicNil)
|
||||
path = SymPath [] t
|
||||
preExistingModule = case lookupBinderInGlobalEnv ctx path of
|
||||
Just (Binder _ (XObj (Mod found) _ _)) -> Just found
|
||||
Right (Binder _ (XObj (Mod found et) _ _)) -> Just (found, et)
|
||||
_ -> Nothing
|
||||
|
||||
notFound :: Context -> XObj -> SymPath -> IO (Context, Either EvalError XObj)
|
||||
notFound ctx x path = pure (toEvalError ctx x (SymbolNotFoundError path))
|
||||
|
||||
-- | Get information about a binding.
|
||||
primitiveInfo :: UnaryPrimitiveCallback
|
||||
primitiveInfo _ ctx target@(XObj (Sym path@(SymPath _ _) _) _ _) =
|
||||
primitiveInfo _ ctx target@(XObj (Sym path@(SymPath _ name) _) _ _) =
|
||||
case path of
|
||||
SymPath [] _ ->
|
||||
do
|
||||
let found = lookupBinderInTypeEnv ctx path
|
||||
_ <- printIfFound found
|
||||
_ <- 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
|
||||
otherBindings =
|
||||
fmap (: []) (lookupBinderInContextEnv ctx path)
|
||||
<|> multiLookupBinderEverywhere ctx path
|
||||
<> (Right (lookupBinderEverywhere (contextGlobalEnv ctx) name))
|
||||
_ ->
|
||||
do
|
||||
let found = lookupBinderInTypeEnv ctx path
|
||||
let others = lookupBinderInContextEnv ctx path
|
||||
_ <- printIfFound found
|
||||
_ <- maybe (pure ()) printer others
|
||||
maybe (notFound ctx target path) (const ok) (found <|> others)
|
||||
_ <- either (const (pure ())) printer others
|
||||
either (const (notFound ctx target path)) (const ok) (found <> others)
|
||||
where
|
||||
ok :: IO (Context, Either EvalError XObj)
|
||||
ok = pure (ctx, dynamicNil)
|
||||
printInterfaceImplementationsOrAll :: Maybe Binder -> Maybe [Binder] -> IO ()
|
||||
printInterfaceImplementationsOrAll :: Either ContextError Binder -> Either ContextError [Binder] -> IO ()
|
||||
printInterfaceImplementationsOrAll interface impls =
|
||||
maybe
|
||||
(pure ())
|
||||
either
|
||||
(const (pure ()))
|
||||
(foldM (\_ binder -> printer binder) ())
|
||||
( ( interface
|
||||
>>= \binder ->
|
||||
@ -302,7 +308,7 @@ primitiveInfo _ ctx target@(XObj (Sym path@(SymPath _ _) _) _ _) =
|
||||
fmap (filter (implementsInterface binder)) impls
|
||||
_ -> impls
|
||||
)
|
||||
<|> impls
|
||||
<> impls
|
||||
)
|
||||
implementsInterface :: Binder -> Binder -> Bool
|
||||
implementsInterface binder binder' =
|
||||
@ -310,8 +316,8 @@ primitiveInfo _ ctx target@(XObj (Sym path@(SymPath _ _) _) _ _) =
|
||||
False
|
||||
(\(XObj (Lst impls) _ _) -> getBinderPath binder `elem` map getPath impls)
|
||||
(Meta.getBinderMetaValue "implements" binder')
|
||||
printIfFound :: Maybe Binder -> IO ()
|
||||
printIfFound = maybe (pure ()) printer
|
||||
printIfFound :: Either ContextError Binder -> IO ()
|
||||
printIfFound = either (const (pure ())) printer
|
||||
printer :: Binder -> IO ()
|
||||
printer binder@(Binder metaData x@(XObj _ (Just i) _)) =
|
||||
putStrLnWithColor Blue (forceShowBinder binder)
|
||||
@ -345,101 +351,63 @@ dynamicOrMacroWith :: Context -> (SymPath -> [XObj]) -> Ty -> String -> XObj ->
|
||||
dynamicOrMacroWith ctx producer ty name body = do
|
||||
let qpath = qualifyPath ctx (SymPath [] name)
|
||||
elt = XObj (Lst (producer (unqualify qpath))) (xobjInfo body) (Just ty)
|
||||
meta = lookupMeta (getPath elt) (contextGlobalEnv ctx)
|
||||
pure (insertInGlobalEnv ctx qpath (Binder meta elt), dynamicNil)
|
||||
meta = fromRight emptyMeta (lookupMeta (contextGlobalEnv ctx) (getPath elt))
|
||||
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 _ ctx target = do
|
||||
case bottomedTarget target of
|
||||
XObj (Sym path@(SymPath _ name) _) _ _ ->
|
||||
case lookupBinderInTypeEnv ctx path of
|
||||
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))
|
||||
primitiveMembers _ ctx xobj@(XObj (Sym path _) _ _) =
|
||||
case (lookupBinderInTypeEnv ctx path) of
|
||||
Left _ -> pure $ toEvalError ctx xobj (StructNotFound xobj)
|
||||
Right b -> go (binderXObj b)
|
||||
where
|
||||
bottomedTarget t =
|
||||
case t of
|
||||
XObj (Sym targetPath _) _ _ ->
|
||||
case lookupBinderInContextEnv ctx targetPath of
|
||||
-- this is a trick: every type generates a module in the env;
|
||||
-- we’re special-casing here because we need the parent of the
|
||||
-- module
|
||||
Just (Binder _ (XObj (Mod _) _ _)) -> t
|
||||
-- if we’re recursing into a non-sym, we’ll stop one level down
|
||||
Just (Binder _ x) -> bottomedTarget x
|
||||
_ -> target
|
||||
_ -> target
|
||||
go :: XObj -> IO (Context, Either EvalError XObj)
|
||||
go (XObj (Lst [(XObj (Deftype _) _ _), _, (XObj (Arr members) _ _)]) _ _) =
|
||||
pure (ctx, Right (XObj (Arr (map (\(a, b) -> XObj (Lst [a, b]) Nothing Nothing) (pairwise members))) Nothing Nothing))
|
||||
go (XObj (Lst ((XObj (DefSumtype _) _ _) : _ : cases)) _ _) =
|
||||
pure $ (ctx, (either Left (\a -> Right (XObj (Arr (concat a)) Nothing Nothing)) (mapM getMembersFromCase cases)))
|
||||
go x = pure (toEvalError ctx x (NonTypeInTypeEnv path x))
|
||||
|
||||
getMembersFromCase :: XObj -> Either EvalError [XObj]
|
||||
getMembersFromCase (XObj (Lst members) _ _) =
|
||||
Right (map (\(a, b) -> XObj (Lst [a, b]) Nothing Nothing) (pairwise members))
|
||||
getMembersFromCase x@(XObj (Sym _ _) _ _) =
|
||||
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
|
||||
--
|
||||
-- Permits "forward-declaration": if the binder doesn't exist, it creates a
|
||||
-- "meta stub" for the binder with the meta information.
|
||||
primitiveMetaSet :: TernaryPrimitiveCallback
|
||||
primitiveMetaSet _ ctx target@(XObj (Sym path@(SymPath prefixes _) _) _ _) (XObj (Str key) _ _) value =
|
||||
pure $ maybe create (,dynamicNil) lookupAndUpdate
|
||||
primitiveMetaSet _ ctx target@(XObj (Sym path@(SymPath _ _) _) _ _) (XObj (Str key) _ _) value =
|
||||
pure $ either (const create) (,dynamicNil) (lookupGlobal <> lookupType)
|
||||
where
|
||||
qpath = qualifyPath ctx path
|
||||
fullPath@(SymPath modules _) = unqualify qpath
|
||||
lookupAndUpdate :: Maybe Context
|
||||
lookupAndUpdate =
|
||||
( lookupBinderInGlobalEnv ctx path
|
||||
>>= \binder ->
|
||||
pure (Meta.updateBinderMeta binder key value)
|
||||
>>= pure . (insertInGlobalEnv ctx qpath)
|
||||
)
|
||||
-- This is a global name but it doesn't exist in the global env
|
||||
-- Before creating a new binder, check that it doesn't denote an existing type or interface.
|
||||
<|> if null modules
|
||||
then
|
||||
lookupBinderInTypeEnv ctx qpath
|
||||
>>= \binder ->
|
||||
pure (Meta.updateBinderMeta binder key value)
|
||||
>>= pure . (insertInTypeEnv ctx qpath)
|
||||
else Nothing
|
||||
lookupGlobal :: Either ContextError Context
|
||||
lookupGlobal =
|
||||
lookupBinderInGlobalEnv ctx path
|
||||
>>= \binder ->
|
||||
pure (Meta.updateBinderMeta binder key value)
|
||||
>>= insertInGlobalEnv ctx qpath
|
||||
lookupType :: Either ContextError Context
|
||||
lookupType =
|
||||
lookupBinderInTypeEnv ctx qpath
|
||||
>>= \binder ->
|
||||
pure (Meta.updateBinderMeta binder key value)
|
||||
>>= insertTypeBinder ctx qpath
|
||||
create :: (Context, Either EvalError XObj)
|
||||
create =
|
||||
-- TODO: Remove the special casing here (null check) and throw a general
|
||||
-- error when modules don't exist
|
||||
if null prefixes
|
||||
then
|
||||
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)
|
||||
let updated = Meta.updateBinderMeta (Meta.stub (unqualify qpath)) key value
|
||||
in case (insertInGlobalEnv ctx qpath updated) of
|
||||
Left e -> toEvalError ctx target (MetaSetFailed target (show e))
|
||||
Right c -> (c, dynamicNil)
|
||||
primitiveMetaSet _ ctx (XObj (Sym (SymPath _ _) _) _ _) key _ =
|
||||
argumentErr ctx "meta-set!" "a string" "second" key
|
||||
primitiveMetaSet _ ctx target _ _ =
|
||||
@ -450,13 +418,13 @@ primitiveDefinterface xobj ctx nameXObj@(XObj (Sym path@(SymPath [] name) _) _ _
|
||||
pure $ maybe invalidType validType (xobjToTy ty)
|
||||
where
|
||||
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
|
||||
defInterface =
|
||||
let interface = defineInterface name t [] (xobjInfo nameXObj)
|
||||
binder = toBinder interface
|
||||
ctx' = insertInTypeEnv ctx (markQualified (SymPath [] name)) binder
|
||||
newCtx = retroactivelyRegisterInInterface ctx' binder
|
||||
Right ctx' = insertTypeBinder ctx (markQualified (SymPath [] name)) binder
|
||||
Right newCtx = retroactivelyRegisterInInterface ctx' binder
|
||||
in (newCtx, dynamicNil)
|
||||
updateInterface binder = case binder of
|
||||
Binder _ (XObj (Lst (XObj (Interface foundType _) _ _ : _)) _ _) ->
|
||||
@ -502,8 +470,10 @@ registerInternal ctx name ty override =
|
||||
)
|
||||
(xobjInfo ty)
|
||||
(Just t)
|
||||
meta = lookupMeta (getPath registration) (contextGlobalEnv ctx)
|
||||
in (insertInGlobalEnv ctx qpath (Binder meta registration), dynamicNil)
|
||||
meta = fromRight emptyMeta (lookupMeta (contextGlobalEnv ctx) (getPath registration))
|
||||
in case (insertInGlobalEnv ctx qpath (Binder meta registration)) of
|
||||
Left err -> evalError ctx (show err) (xobjInfo ty)
|
||||
Right c -> (c, dynamicNil)
|
||||
|
||||
primitiveRegister :: VariadicPrimitiveCallback
|
||||
primitiveRegister _ ctx [XObj (Sym (SymPath [] name) _) _ _, ty] =
|
||||
@ -549,147 +519,158 @@ primitiveRegister x ctx _ =
|
||||
)
|
||||
|
||||
primitiveDeftype :: VariadicPrimitiveCallback
|
||||
primitiveDeftype xobj ctx (name : rest) =
|
||||
case rest of
|
||||
(XObj (Arr a) _ _ : _) ->
|
||||
case members a of
|
||||
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
|
||||
primitiveDeftype xobj ctx (name : rest@(XObj (Arr a) _ _ : _)) =
|
||||
case members a of
|
||||
Nothing -> pure (toEvalError ctx xobj BadDeftypeMembers)
|
||||
Just ms -> ensureUnqualified (map fst ms)
|
||||
where
|
||||
deftype nm@(XObj (Sym (SymPath _ ty) _) _ _) = deftype' nm ty []
|
||||
deftype (XObj (Lst (nm@(XObj (Sym (SymPath _ ty) _) _ _) : tyvars)) _ _) =
|
||||
deftype' nm ty tyvars
|
||||
deftype nm =
|
||||
pure
|
||||
( evalError
|
||||
ctx
|
||||
("Invalid name for type definition: " ++ pretty nm)
|
||||
(xobjInfo nm)
|
||||
)
|
||||
deftype' :: XObj -> String -> [XObj] -> IO (Context, Either EvalError XObj)
|
||||
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"
|
||||
members :: [XObj] -> Maybe [(XObj, XObj)]
|
||||
members [] = Just []
|
||||
members [_] = Nothing
|
||||
members (binding : val : xs) = members xs >>= \xs' -> pure $ (binding, val) : xs'
|
||||
ensureUnqualified :: [XObj] -> IO (Context, Either EvalError XObj)
|
||||
ensureUnqualified objs =
|
||||
if all isUnqualifiedSym objs
|
||||
then deftype ctx name (selectConstructor rest)
|
||||
else pure (toEvalError ctx xobj (QualifiedTypeMember rest))
|
||||
primitiveDeftype _ ctx (name : rest) =
|
||||
deftype ctx name (selectConstructor rest)
|
||||
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 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
|
||||
pathStrings = contextPath ctx
|
||||
env = contextGlobalEnv ctx
|
||||
e = getEnv env pathStrings
|
||||
useThese = envUseModules e
|
||||
e' = e {envUseModules = Set.insert path useThese}
|
||||
lookupInGlobal = maybe missing useModule (lookupInEnv path env)
|
||||
where
|
||||
missing = evalError ctx ("Can't find a module named '" ++ show path ++ "'") (xobjInfo xobj)
|
||||
useModule _ = (replaceGlobalEnv ctx (envReplaceEnvAt env pathStrings e'), dynamicNil)
|
||||
updateGlobalUsePaths :: Env -> SymPath -> (Context, Either EvalError XObj)
|
||||
updateGlobalUsePaths e spath =
|
||||
((replaceGlobalEnv ctx (addUsePath e spath)), dynamicNil)
|
||||
|
||||
updateModuleUsePaths :: Env -> SymPath -> Binder -> SymPath -> (Context, Either EvalError XObj)
|
||||
updateModuleUsePaths e p (Binder meta (XObj (Mod ev et) i t)) spath =
|
||||
either
|
||||
(\err -> (evalError ctx err (xobjInfo xobj)))
|
||||
(\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 =
|
||||
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'
|
||||
where
|
||||
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 = (ctx, maybe dynamicNil Right (Meta.getBinderMetaValue key binder))
|
||||
errNotFound :: (Context, Either EvalError XObj)
|
||||
@ -711,14 +692,14 @@ primitiveMeta _ ctx path _ =
|
||||
|
||||
primitiveDefined :: UnaryPrimitiveCallback
|
||||
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 =
|
||||
argumentErr ctx "defined" "a symbol" "first" arg
|
||||
|
||||
primitiveDeftemplate :: QuaternaryPrimitiveCallback
|
||||
-- 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) _ _) =
|
||||
pure $ maybe invalidType validType (xobjToTy ty)
|
||||
pure $ maybe invalidType (fromRight invalidType . fmap (\x -> (x, dynamicNil)) . validType) (xobjToTy ty)
|
||||
where
|
||||
typeEnv = contextTypeEnv ctx
|
||||
globalEnv = contextGlobalEnv ctx
|
||||
@ -728,13 +709,13 @@ primitiveDeftemplate _ ctx (XObj (Sym p@(SymPath [] _) _) _ _) ty (XObj (Str dec
|
||||
if isTypeGeneric t
|
||||
then
|
||||
let (Binder _ registration) = b
|
||||
meta = lookupMeta (getPath registration) globalEnv
|
||||
in (insertInGlobalEnv ctx (qualifyPath ctx p) (Binder meta registration), dynamicNil)
|
||||
meta = fromRight emptyMeta (lookupMeta globalEnv (getPath registration))
|
||||
in insertInGlobalEnv ctx (qualifyPath ctx p) (Binder meta registration)
|
||||
else
|
||||
let templateCreator = getTemplateCreator template
|
||||
(registration, _) = instantiateTemplate (contextualize p ctx) t (templateCreator typeEnv globalEnv)
|
||||
meta = lookupMeta (getPath registration) globalEnv
|
||||
in (insertInGlobalEnv ctx (qualifyPath ctx p) (Binder meta registration), dynamicNil)
|
||||
meta = fromRight emptyMeta (lookupMeta globalEnv (getPath registration))
|
||||
in insertInGlobalEnv ctx (qualifyPath ctx p) (Binder meta registration)
|
||||
_ -> error "primitivedeftemplate1"
|
||||
primitiveDeftemplate _ ctx (XObj (Sym (SymPath [] _) _) _ _) _ (XObj (Str _) _ _) x =
|
||||
argumentErr ctx "deftemplate" "a string" "fourth" x
|
||||
@ -754,10 +735,10 @@ primitiveType _ ctx (XObj _ _ (Just Universe)) =
|
||||
pure (ctx, Right (XObj (Lst []) Nothing Nothing))
|
||||
primitiveType _ ctx (XObj _ _ (Just TypeTy)) = liftIO $ pure (ctx, Right $ reify TypeTy)
|
||||
primitiveType _ ctx x@(XObj (Sym path@(SymPath [] name) _) _ _) =
|
||||
maybe otherDefs go (lookupBinderInGlobalEnv ctx path)
|
||||
fromRight otherDefs (second go (lookupBinderInGlobalEnv ctx path))
|
||||
where
|
||||
env = contextGlobalEnv ctx
|
||||
otherDefs = case multiLookupEverywhere name env of
|
||||
otherDefs = case lookupEverywhere env name of
|
||||
[] ->
|
||||
notFound ctx x path
|
||||
binders ->
|
||||
@ -771,7 +752,7 @@ primitiveType _ ctx x@(XObj (Sym path@(SymPath [] name) _) _ _) =
|
||||
Nothing -> noTypeError ctx x
|
||||
Just t -> pure (ctx, Right (reify t))
|
||||
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
|
||||
go binder =
|
||||
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
|
||||
@ -16,15 +18,14 @@ module Qualify
|
||||
where
|
||||
|
||||
import Control.Monad (foldM, liftM)
|
||||
import Data.List (foldl')
|
||||
import Debug.Trace
|
||||
import Env
|
||||
import Data.Bifunctor
|
||||
import Data.Either (fromRight)
|
||||
import qualified Env as E
|
||||
import Info
|
||||
import Lookup
|
||||
import qualified Map
|
||||
import Obj
|
||||
import qualified Set
|
||||
import Types
|
||||
import SymPath
|
||||
import Util
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
@ -35,6 +36,11 @@ data QualificationError
|
||||
= FailedToQualifyDeclarationName XObj
|
||||
| FailedToQualifySymbols XObj
|
||||
| FailedToQualifyPath SymPath
|
||||
| NonVariableInMatch XObj
|
||||
| NakedInitForUnnamedModule [String]
|
||||
| QualifiedMulti SymPath
|
||||
| LocalMulti SymPath [(Env, Binder)]
|
||||
| FailedToFindSymbol XObj
|
||||
|
||||
instance Show QualificationError where
|
||||
show (FailedToQualifyDeclarationName xobj) =
|
||||
@ -44,6 +50,18 @@ instance Show QualificationError where
|
||||
show (FailedToQualifyPath spath) =
|
||||
"Couldn't fully qualify the symbol: " ++ show spath
|
||||
++ "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
|
||||
@ -52,7 +70,7 @@ instance Show QualificationError where
|
||||
--
|
||||
-- A fully qualified xobj **must not** be qualified further (e.g. using context
|
||||
-- paths).
|
||||
newtype Qualified = Qualified {unQualified :: XObj}
|
||||
newtype Qualified = Qualified {unQualified :: XObj} deriving (Show)
|
||||
|
||||
-- | Denotes a symbol that has been fully qualified.
|
||||
newtype QualifiedPath = QualifiedPath SymPath
|
||||
@ -115,10 +133,10 @@ qualify ctx xobj@(XObj obj info ty) =
|
||||
-- TODO: Merge this with setFullyQualifiedSymbols
|
||||
case obj of
|
||||
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] ->
|
||||
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 (Lst [def, (XObj (Sym (SymPath pathStrings name) mode) symi symt), expr]) info ty)
|
||||
_ -> inner >>= \i -> setFullyQualifiedSymbols t g i xobj
|
||||
where
|
||||
pathStrings :: [String]
|
||||
pathStrings = contextPath ctx
|
||||
@ -126,8 +144,8 @@ qualify ctx xobj@(XObj obj info ty) =
|
||||
t = contextTypeEnv ctx
|
||||
g :: Env
|
||||
g = contextGlobalEnv ctx
|
||||
i :: Env
|
||||
i = getEnv g pathStrings
|
||||
inner :: Either QualificationError Env
|
||||
inner = replaceLeft (FailedToQualifySymbols xobj) (E.getInnerEnv g pathStrings)
|
||||
|
||||
-- | 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.
|
||||
@ -176,29 +194,32 @@ type Qualifier = TypeEnv -> Env -> Env -> XObj -> Either QualificationError Qual
|
||||
|
||||
-- | Qualify the symbols in a Defn form's body.
|
||||
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.
|
||||
-- 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.
|
||||
-- Note: These inner envs is ephemeral since they are not stored in a module or global scope.
|
||||
do
|
||||
let recursionEnv = Env Map.empty (Just env) (Just (functionName ++ "-recurse-env")) Set.empty RecursionEnv 0
|
||||
envWithSelf = extendEnv recursionEnv functionName sym
|
||||
functionEnv = Env Map.empty (Just envWithSelf) Nothing Set.empty InternalEnv 0
|
||||
envWithArgs = foldl' (\e arg@(XObj (Sym (SymPath _ argSymName) _) _ _) -> extendEnv e argSymName arg) functionEnv argsArr
|
||||
recursionEnv <- fixLeft (pure (E.recursive (Just env) (Just (functionName ++ "-recurse-env")) 0))
|
||||
envWithSelf <- fixLeft (E.insertX recursionEnv (SymPath [] functionName) sym)
|
||||
-- Copy the use modules from the local env to ensure they are available from the function env.
|
||||
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)
|
||||
pure (Qualified (XObj (Lst [defn, sym, args, qualifiedBody]) i t))
|
||||
where
|
||||
fixLeft = replaceLeft (FailedToQualifyDeclarationName x)
|
||||
qualifyFunctionDefinition _ _ _ xobj = Left $ FailedToQualifyDeclarationName xobj
|
||||
|
||||
-- | Qualify the symbols in a lambda body.
|
||||
qualifyLambda :: Qualifier
|
||||
qualifyLambda typeEnv globalEnv env (XObj (Lst [fn@(XObj (Fn _ _) _ _), args@(XObj (Arr argsArr) _ _), body]) i t) =
|
||||
do
|
||||
let lvl = envFunctionNestingLevel env
|
||||
functionEnv = Env Map.empty (Just env) Nothing Set.empty InternalEnv (lvl + 1)
|
||||
envWithArgs = foldl' (\e arg@(XObj (Sym (SymPath _ argSymName) _) _ _) -> extendEnv e argSymName arg) functionEnv argsArr
|
||||
qualifiedBody <- liftM unQualified (setFullyQualifiedSymbols typeEnv globalEnv envWithArgs body)
|
||||
pure (Qualified (XObj (Lst [fn, args, qualifiedBody]) i t))
|
||||
qualifyLambda typeEnv globalEnv env x@(XObj (Lst [fn@(XObj (Fn _ _) _ _), args@(XObj (Arr argsArr) _ _), body]) i t) =
|
||||
let lvl = envFunctionNestingLevel env
|
||||
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 ->
|
||||
liftM unQualified (setFullyQualifiedSymbols typeEnv globalEnv envWithArgs body)
|
||||
>>= \qualifiedBody -> pure (Qualified (XObj (Lst [fn, args, qualifiedBody]) i t))
|
||||
qualifyLambda _ _ _ xobj = Left $ FailedToQualifySymbols xobj
|
||||
|
||||
-- | 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.
|
||||
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.
|
||||
| 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 =
|
||||
@ -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))
|
||||
where
|
||||
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
|
||||
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"
|
||||
qualifyLet _ _ _ xobj = Left $ FailedToQualifySymbols xobj
|
||||
|
||||
-- | Qualify symbols in a Match form.
|
||||
qualifyMatch :: Qualifier
|
||||
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 =
|
||||
do
|
||||
qualifiedExpr <- pure . unQualified =<< setFullyQualifiedSymbols typeEnv globalEnv env expr
|
||||
@ -251,26 +274,33 @@ qualifyMatch typeEnv globalEnv env (XObj (Lst (matchExpr@(XObj (Match _) _ _) :
|
||||
where
|
||||
Just ii = i
|
||||
lvl = envFunctionNestingLevel env
|
||||
-- Create an inner environment for each case.
|
||||
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 (l@(XObj (Lst (_ : xs)) _ _), r) =
|
||||
do
|
||||
let innerEnv' = foldl' foldVars innerEnv xs
|
||||
qualifiedLHS <- setFullyQualifiedSymbols typeEnv globalEnv env l
|
||||
innerEnv' <- foldM foldVars innerEnv xs
|
||||
qualifiedLHS <- setFullyQualifiedSymbols typeEnv globalEnv innerEnv' l
|
||||
qualifiedRHS <- setFullyQualifiedSymbols typeEnv globalEnv innerEnv' r
|
||||
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) =
|
||||
do
|
||||
qualifiedLHS <- setFullyQualifiedSymbols typeEnv globalEnv env l
|
||||
qualifiedRHS <- setFullyQualifiedSymbols typeEnv globalEnv env r
|
||||
Right [qualifiedLHS, qualifiedRHS]
|
||||
foldVars :: Env -> XObj -> Env
|
||||
foldVars env' v@(XObj (Sym (SymPath _ binderName) _) _ _) = extendEnv env' binderName v
|
||||
-- Nested sumtypes
|
||||
-- fold recursively -- is there a more efficient way?
|
||||
foldVars _ (XObj (Lst (_ : ys)) _ _) = foldl' foldVars innerEnv ys
|
||||
foldVars _ v = error ("Can't match variable with " ++ show v)
|
||||
-- Add variables in a case to its environment
|
||||
foldVars :: Env -> XObj -> Either QualificationError Env
|
||||
foldVars env' v@(XObj (Sym path _) _ _) = (replaceLeft (FailedToQualifySymbols v) (E.insertX env' path v))
|
||||
-- Nested sumtypes; fold recursively -- is there a more efficient way?
|
||||
foldVars _ (XObj (Lst (_ : ys)) _ _) = foldM foldVars innerEnv ys
|
||||
foldVars _ v = Left $ NonVariableInMatch v
|
||||
qualifyMatch _ _ _ xobj = Left $ FailedToQualifySymbols xobj
|
||||
|
||||
-- | Qualify symbols in a With form.
|
||||
@ -291,104 +321,93 @@ qualifyLst typeEnv globalEnv env (XObj (Lst xobjs) i t) =
|
||||
qualifyLst _ _ _ xobj = Left $ FailedToQualifySymbols xobj
|
||||
|
||||
-- | Qualify a single symbol.
|
||||
-- TODO: Clean this up
|
||||
qualifySym :: Qualifier
|
||||
qualifySym typeEnv globalEnv localEnv xobj@(XObj (Sym path _) i t) =
|
||||
Right $
|
||||
Qualified $
|
||||
case path of
|
||||
-- Unqualified:
|
||||
SymPath [] name ->
|
||||
case lookupBinder path (getTypeEnv typeEnv) of
|
||||
Just (Binder _ (XObj (Lst (XObj (Interface _ _) _ _ : _)) _ _)) ->
|
||||
-- Found an interface with the same path!
|
||||
-- Have to ensure it's not a local variable with the same name as the interface
|
||||
case lookupInEnv path localEnv of
|
||||
Just (foundEnv, _) ->
|
||||
if envIsExternal foundEnv
|
||||
then createInterfaceSym name
|
||||
else doesNotBelongToAnInterface False localEnv
|
||||
Nothing ->
|
||||
--trace ("Will turn '" ++ show path ++ "' " ++ prettyInfoFromXObj xobj ++ " into an interface symbol.")
|
||||
createInterfaceSym name
|
||||
_ ->
|
||||
doesNotBelongToAnInterface False localEnv
|
||||
-- Qualified:
|
||||
_ ->
|
||||
doesNotBelongToAnInterface False localEnv
|
||||
-- Unqualified path.
|
||||
qualifySym typeEnv globalEnv localEnv xobj@(XObj (Sym path@(SymPath _ name) _) i t) =
|
||||
( ( ( replaceLeft
|
||||
(FailedToFindSymbol xobj)
|
||||
-- TODO: Why do we need getValue here? We should be able to restrict this
|
||||
-- search only to direct children of the type environment, but this causes
|
||||
-- errors.
|
||||
( fmap (\(e, b) -> ((E.prj typeEnv), (E.prj e, b))) (E.searchType typeEnv path)
|
||||
<> fmap (localEnv,) (E.searchValue localEnv path)
|
||||
<> fmap (globalEnv,) (E.searchValue globalEnv path)
|
||||
)
|
||||
)
|
||||
>>= \(origin, (e, binder)) ->
|
||||
resolve (E.prj origin) (E.prj e) (binderXObj binder)
|
||||
>>= pure . Qualified
|
||||
)
|
||||
<> ((resolveMulti path (E.lookupInUsed localEnv globalEnv path)) >>= pure . Qualified)
|
||||
<> ((replaceLeft (FailedToFindSymbol xobj) (E.lookupContextually globalEnv path)) >>= (resolveMulti path) >>= pure . Qualified)
|
||||
<> ((resolveMulti path (E.lookupEverywhere globalEnv name)) >>= pure . Qualified)
|
||||
<> pure (Qualified xobj)
|
||||
)
|
||||
where
|
||||
createInterfaceSym name =
|
||||
XObj (InterfaceSym name) i t
|
||||
captureOrNot foundEnv =
|
||||
if envFunctionNestingLevel foundEnv < envFunctionNestingLevel localEnv
|
||||
then Capture (envFunctionNestingLevel localEnv - envFunctionNestingLevel foundEnv)
|
||||
else NoCapture
|
||||
doesNotBelongToAnInterface :: Bool -> Env -> XObj
|
||||
doesNotBelongToAnInterface finalRecurse theEnv =
|
||||
let results = multiLookupQualified path theEnv
|
||||
results' = removeThoseShadowedByRecursiveSymbol results
|
||||
in case results' of
|
||||
[] -> case envParent theEnv of
|
||||
Just p ->
|
||||
doesNotBelongToAnInterface False p
|
||||
Nothing ->
|
||||
-- OBS! The environment with no parent is the global env but it's an old one without the latest bindings!
|
||||
if finalRecurse
|
||||
then xobj -- This was the TRUE global env, stop here and leave 'xobj' as is.
|
||||
else doesNotBelongToAnInterface True globalEnv
|
||||
[(_, Binder _ foundOne@(XObj (Lst (XObj (External (Just overrideWithName)) _ _ : _)) _ _))] ->
|
||||
XObj (Sym (getPath foundOne) (LookupGlobalOverride overrideWithName)) i t
|
||||
[(e, Binder _ (XObj (Mod modEnv) _ _))] ->
|
||||
-- Lookup of a "naked" module name means that the Carp code is trying to
|
||||
-- instantiate a (nested) module with an implicit .init, e.g. (Pair 1 2)
|
||||
case envModuleName modEnv of
|
||||
Nothing -> error ("Can't get name from unqualified module path: " ++ show path)
|
||||
Just name ->
|
||||
let pathHere = pathToEnv e
|
||||
in XObj (Sym (SymPath (pathHere ++ [name]) "init") (LookupGlobal CarpLand AFunction)) i t
|
||||
[(e, Binder _ foundOne)] ->
|
||||
case envMode e of
|
||||
ExternalEnv ->
|
||||
XObj
|
||||
( Sym
|
||||
(getPath foundOne)
|
||||
(LookupGlobal (if isExternalFunction foundOne then ExternalCode else CarpLand) (definitionMode foundOne))
|
||||
)
|
||||
i
|
||||
t
|
||||
RecursionEnv -> XObj (Sym (getPath foundOne) LookupRecursive) i t
|
||||
_ ->
|
||||
--trace ("\nLOCAL variable " ++ show (getPath foundOne) ++ ":\n" ++ prettyEnvironmentChain e) $
|
||||
XObj (Sym (getPath foundOne) (LookupLocal (captureOrNot e))) i t
|
||||
multiple ->
|
||||
case filter (not . envIsExternal . fst) multiple of
|
||||
-- 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
|
||||
-- There are no local bindings, this is allowed to become a multi lookup symbol:
|
||||
[] ->
|
||||
-- (trace $ "Turned " ++ show path ++ " into multisym: " ++ joinWithComma (map (show . (\(e, b) -> (getPath (binderXObj b), safeEnvModuleName e, envMode e))) multiple)) $
|
||||
case path of
|
||||
(SymPath [] name) ->
|
||||
-- Create a MultiSym!
|
||||
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
|
||||
resolve :: Env -> Env -> XObj -> Either QualificationError XObj
|
||||
resolve _ _ (XObj (Lst (XObj (Interface _ _) _ _ : _)) _ _) =
|
||||
-- Before we return an interface, double check that it isn't shadowed by a local let-binding.
|
||||
case (E.searchValue localEnv path) of
|
||||
Right (e, Binder _ _) ->
|
||||
case envMode e of
|
||||
InternalEnv -> pure (XObj (Sym (getPath xobj) (LookupLocal (captureOrNot e localEnv))) i t)
|
||||
_ -> pure (XObj (InterfaceSym name) i t)
|
||||
_ -> pure (XObj (InterfaceSym name) i t)
|
||||
resolve _ _ x@(XObj (Lst (XObj (External (Just overrideName)) _ _ : _)) _ _) =
|
||||
pure (XObj (Sym (getPath x) (LookupGlobalOverride overrideName)) i t)
|
||||
resolve _ _ (XObj (Mod modenv _) _ _) =
|
||||
nakedInit modenv
|
||||
resolve origin found xobj' =
|
||||
if (isTypeDef xobj')
|
||||
then
|
||||
( (replaceLeft (FailedToFindSymbol xobj') (fmap (globalEnv,) (E.searchValue globalEnv path)))
|
||||
>>= \(origin', (e', binder)) -> resolve (E.prj origin') (E.prj e') (binderXObj binder)
|
||||
)
|
||||
else case envMode (E.prj found) of
|
||||
RecursionEnv -> pure (XObj (Sym (getPath xobj') LookupRecursive) i t)
|
||||
InternalEnv -> pure (XObj (Sym (getPath xobj') (LookupLocal (captureOrNot found origin))) i t)
|
||||
ExternalEnv -> pure (XObj (Sym (getPath xobj') (LookupGlobal (if isExternalFunction xobj' then ExternalCode else CarpLand) (definitionMode xobj'))) i t)
|
||||
resolveMulti :: (Show e, E.Environment e) => SymPath -> [(e, Binder)] -> Either QualificationError XObj
|
||||
resolveMulti _ [] =
|
||||
Left (FailedToFindSymbol xobj)
|
||||
resolveMulti _ [(e, b)] =
|
||||
resolve (E.prj e) (E.prj e) (binderXObj b)
|
||||
resolveMulti spath xs =
|
||||
let localOnly = remove (E.envIsExternal . fst) xs
|
||||
paths = map (getModuleSym . (second binderXObj)) xs
|
||||
in case localOnly of
|
||||
[] -> case spath of
|
||||
(SymPath [] _) ->
|
||||
Right $ XObj (MultiSym name paths) i t
|
||||
_ -> Left (QualifiedMulti spath)
|
||||
ys -> Left (LocalMulti spath (map (first E.prj) ys))
|
||||
nakedInit :: Env -> Either QualificationError XObj
|
||||
nakedInit e =
|
||||
maybe
|
||||
(Left (NakedInitForUnnamedModule (pathToEnv e)))
|
||||
(Right . id)
|
||||
( envModuleName e
|
||||
>>= \name' ->
|
||||
pure (XObj (Sym (SymPath ((init (pathToEnv e)) ++ [name']) "init") (LookupGlobal CarpLand AFunction)) i t)
|
||||
)
|
||||
getModuleSym (_, x) =
|
||||
case x of
|
||||
XObj (Mod ev _) _ _ ->
|
||||
fromRight
|
||||
(SymPath (init (pathToEnv ev)) name)
|
||||
( (replaceLeft (FailedToFindSymbol x) (E.searchType globalEnv (SymPath (init (pathToEnv ev)) name)))
|
||||
>> (fmap getPath (nakedInit ev))
|
||||
)
|
||||
res
|
||||
bs
|
||||
_ -> (getPath x)
|
||||
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.
|
||||
qualifyArr :: Qualifier
|
||||
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 TypeTy = XObj (Sym (SymPath [] (show TypeTy)) Symbol) Nothing (Just Universe)
|
||||
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)
|
||||
|
||||
instance Reifiable String where
|
||||
|
@ -52,7 +52,7 @@ saveDocsForEnvs ctx pathsAndEnvBinders =
|
||||
getEnvAndMetaFromBinder :: Binder -> (Env, MetaData)
|
||||
getEnvAndMetaFromBinder envBinder =
|
||||
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'."
|
||||
|
||||
projectIndexPage :: Project -> [String] -> String
|
||||
|
@ -1,7 +1,7 @@
|
||||
module Scoring (scoreTypeBinder, scoreValueBinder) where
|
||||
|
||||
import Data.Maybe (fromJust)
|
||||
import Lookup
|
||||
import Env as E
|
||||
import Obj
|
||||
import qualified Set
|
||||
import Types
|
||||
@ -24,15 +24,12 @@ scoreTypeBinder typeEnv b@(Binder _ (XObj (Lst (XObj x _ _ : XObj (Sym _ _) _ _
|
||||
ExternalType _ -> (0, b)
|
||||
_ -> (500, b)
|
||||
where
|
||||
depthOfStruct (StructTy (ConcreteNameTy structName) varTys) =
|
||||
case lookupBinder (SymPath lookupPath name) (getTypeEnv typeEnv) of
|
||||
Just (Binder _ typedef) -> (depthOfDeftype typeEnv Set.empty typedef varTys + 1, b)
|
||||
Nothing -> error ("Can't find user defined type '" ++ structName ++ "' in type env.")
|
||||
where
|
||||
lookupPath = getPathFromStructName structName
|
||||
name = getNameFromStructName structName
|
||||
depthOfStruct (StructTy (ConcreteNameTy (SymPath _ name)) varTys) =
|
||||
case E.getTypeBinder typeEnv name of
|
||||
Right (Binder _ typedef) -> (depthOfDeftype typeEnv Set.empty typedef varTys + 1, b)
|
||||
Left e -> error (show e)
|
||||
depthOfStruct _ = error "depthofstruct"
|
||||
scoreTypeBinder _ b@(Binder _ (XObj (Mod _) _ _)) =
|
||||
scoreTypeBinder _ b@(Binder _ (XObj (Mod _ _) _ _)) =
|
||||
(1000, b)
|
||||
scoreTypeBinder _ x = error ("Can't score: " ++ show x)
|
||||
|
||||
@ -79,17 +76,19 @@ depthOfType typeEnv visited selfName theType =
|
||||
_
|
||||
| tyToC struct == selfName -> 1
|
||||
| otherwise ->
|
||||
case lookupBinder (SymPath lookupPath s) (getTypeEnv typeEnv) of
|
||||
Just (Binder _ typedef) -> moduleDepth + depthOfDeftype typeEnv (Set.insert theType visited) typedef varTys
|
||||
where
|
||||
moduleDepth = length lookupPath * 1000 -- modules have score 1000
|
||||
Nothing ->
|
||||
case E.getTypeBinder typeEnv s of
|
||||
Right (Binder _ typedef) -> depthOfDeftype typeEnv (Set.insert theType visited) typedef varTys
|
||||
Left _ ->
|
||||
--trace ("Unknown type: " ++ name) $
|
||||
depthOfVarTys -- The problem here is that generic types don't generate
|
||||
-- their definition in time so we get nothing for those.
|
||||
-- Instead, let's try the type vars.
|
||||
-- Two problems here:
|
||||
--
|
||||
-- 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
|
||||
lookupPath = getPathFromStructName (getStructName struct)
|
||||
s = getNameFromStructName (getStructName struct)
|
||||
depthOfVarTys =
|
||||
case fmap (depthOfType typeEnv visited (getStructName struct)) varTys of
|
||||
@ -121,12 +120,12 @@ scoreBody globalEnv visited = visit
|
||||
(Sym path (LookupGlobal _ _)) ->
|
||||
if Set.member path visited
|
||||
then 0
|
||||
else case lookupBinder path globalEnv of
|
||||
Just foundBinder ->
|
||||
else case E.searchValueBinder globalEnv path of
|
||||
Right foundBinder ->
|
||||
let (score, _) = scoreValueBinder globalEnv (Set.insert path visited) foundBinder
|
||||
in score + 1
|
||||
Nothing ->
|
||||
error ("Failed to lookup '" ++ show path ++ "'.")
|
||||
Left e ->
|
||||
error (show e)
|
||||
_ -> 0
|
||||
visitList (XObj (Lst []) _ _) =
|
||||
0
|
||||
|
@ -2,6 +2,7 @@ module StartingEnv where
|
||||
|
||||
import qualified ArrayTemplates
|
||||
import Commands
|
||||
import qualified Env as E
|
||||
import Eval
|
||||
import Info
|
||||
import qualified Map
|
||||
@ -123,7 +124,7 @@ functionModule =
|
||||
where
|
||||
bindEnv 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])
|
||||
|
||||
-- | 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)"
|
||||
]
|
||||
mods =
|
||||
[ ("String", Binder emptyMeta (XObj (Mod dynamicStringModule) Nothing Nothing)),
|
||||
("Symbol", Binder emptyMeta (XObj (Mod dynamicSymModule) Nothing Nothing)),
|
||||
("Project", Binder emptyMeta (XObj (Mod dynamicProjectModule) Nothing Nothing)),
|
||||
("Path", Binder emptyMeta (XObj (Mod dynamicPathModule) Nothing Nothing))
|
||||
[ ("String", Binder emptyMeta (XObj (Mod dynamicStringModule E.empty) Nothing Nothing)),
|
||||
("Symbol", Binder emptyMeta (XObj (Mod dynamicSymModule E.empty) Nothing Nothing)),
|
||||
("Project", Binder emptyMeta (XObj (Mod dynamicProjectModule E.empty) 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.
|
||||
@ -494,12 +495,12 @@ startingGlobalEnv noArray =
|
||||
makeSymbol "deref" "" "" Deref,
|
||||
makeSymbol "with" "" "" With
|
||||
]
|
||||
++ [("Array", Binder emptyMeta (XObj (Mod arrayModule) Nothing Nothing)) | not noArray]
|
||||
++ [("StaticArray", Binder emptyMeta (XObj (Mod staticArrayModule) Nothing Nothing))]
|
||||
++ [("Pointer", Binder emptyMeta (XObj (Mod pointerModule) Nothing Nothing))]
|
||||
++ [("Dynamic", Binder emptyMeta (XObj (Mod dynamicModule) Nothing Nothing))]
|
||||
++ [("Function", Binder emptyMeta (XObj (Mod functionModule) Nothing Nothing))]
|
||||
++ [("Unsafe", Binder emptyMeta (XObj (Mod unsafeModule) Nothing Nothing))]
|
||||
++ [("Array", Binder emptyMeta (XObj (Mod arrayModule E.empty) Nothing Nothing)) | not noArray]
|
||||
++ [("StaticArray", Binder emptyMeta (XObj (Mod staticArrayModule E.empty) Nothing Nothing))]
|
||||
++ [("Pointer", Binder emptyMeta (XObj (Mod pointerModule E.empty) Nothing Nothing))]
|
||||
++ [("Dynamic", Binder emptyMeta (XObj (Mod dynamicModule E.empty) Nothing Nothing))]
|
||||
++ [("Function", Binder emptyMeta (XObj (Mod functionModule E.empty) Nothing Nothing))]
|
||||
++ [("Unsafe", Binder emptyMeta (XObj (Mod unsafeModule E.empty) Nothing Nothing))]
|
||||
|
||||
-- | The type environment (containing deftypes and interfaces) before any code is run.
|
||||
startingTypeEnv :: Env
|
||||
|
@ -11,7 +11,7 @@ import Types
|
||||
-- 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.
|
||||
concreteArray :: Ty
|
||||
concreteArray = ConcreteNameTy "StaticArray"
|
||||
concreteArray = ConcreteNameTy (SymPath [] "StaticArray")
|
||||
|
||||
templateUnsafeNth :: (String, Binder)
|
||||
templateUnsafeNth =
|
||||
|
@ -1,14 +1,13 @@
|
||||
module Sumtypes where
|
||||
|
||||
import Concretize
|
||||
import Context
|
||||
import Data.Maybe
|
||||
import Deftype
|
||||
import Env
|
||||
import Env (addListOfBindings, new)
|
||||
import Info
|
||||
import Managed
|
||||
import qualified Map
|
||||
import Obj
|
||||
import qualified Set
|
||||
import StructUtils
|
||||
import SumtypeCase
|
||||
import Template
|
||||
@ -25,13 +24,35 @@ getCase cases caseNameToFind =
|
||||
found : _ -> Just found
|
||||
[] -> 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 =
|
||||
let typeModuleName = typeName
|
||||
typeModuleEnv = fromMaybe (Env (Map.fromList []) innerEnv (Just typeModuleName) Set.empty ExternalEnv 0) existingEnv
|
||||
insidePath = pathStrings ++ [typeModuleName]
|
||||
let moduleValueEnv = fromMaybe (new innerEnv (Just typeName)) (fmap fst existingEnv)
|
||||
moduleTypeEnv = fromMaybe (new (Just typeEnv) (Just typeName)) (fmap snd existingEnv)
|
||||
insidePath = pathStrings ++ [typeName]
|
||||
in do
|
||||
let structTy = StructTy (ConcreteNameTy (createStructName pathStrings typeName)) typeVariables
|
||||
let structTy = StructTy (ConcreteNameTy (SymPath pathStrings typeName)) typeVariables
|
||||
cases <- toCases typeEnv typeVariables rest
|
||||
okIniters <- initers insidePath structTy cases
|
||||
okTag <- binderForTag insidePath structTy
|
||||
@ -40,9 +61,9 @@ moduleForSumtype innerEnv typeEnv env pathStrings typeName typeVariables rest i
|
||||
okDelete <- binderForDelete typeEnv env insidePath structTy cases
|
||||
(okCopy, okCopyDeps) <- binderForCopy typeEnv env insidePath structTy cases
|
||||
okMemberDeps <- memberDeps typeEnv cases
|
||||
let moduleEnvWithBindings = addListOfBindings typeModuleEnv (okIniters ++ [okStr, okPrn, okDelete, okCopy, okTag])
|
||||
typeModuleXObj = XObj (Mod moduleEnvWithBindings) i (Just ModuleTy)
|
||||
pure (typeModuleName, typeModuleXObj, okMemberDeps ++ okCopyDeps ++ okStrDeps)
|
||||
let moduleEnvWithBindings = addListOfBindings moduleValueEnv (okIniters ++ [okStr, okPrn, okDelete, okCopy, okTag])
|
||||
typeModuleXObj = XObj (Mod moduleEnvWithBindings moduleTypeEnv) i (Just ModuleTy)
|
||||
pure (typeName, typeModuleXObj, okMemberDeps ++ okCopyDeps ++ okStrDeps)
|
||||
|
||||
memberDeps :: TypeEnv -> [SumtypeCase] -> Either TypeError [XObj]
|
||||
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 sumTy@(StructTy (ConcreteNameTy typeName) _) sumtypeCase =
|
||||
tokensForCaseInit allocationMode sumTy@(StructTy (ConcreteNameTy _) _) sumtypeCase =
|
||||
toTemplate $
|
||||
unlines
|
||||
[ "$DECL {",
|
||||
case allocationMode of
|
||||
StackAlloc -> " $p instance;"
|
||||
HeapAlloc -> " $p instance = CARP_MALLOC(sizeof(" ++ typeName ++ "));",
|
||||
HeapAlloc -> " $p instance = CARP_MALLOC(sizeof(" ++ show sumTy ++ "));",
|
||||
joinLines $ caseMemberAssignment allocationMode correctedName . fst <$> unitless,
|
||||
" instance._tag = " ++ tagName sumTy correctedName ++ ";",
|
||||
" return instance;",
|
||||
@ -134,7 +155,7 @@ caseMemberAssignment allocationMode caseNm memberName =
|
||||
HeapAlloc -> "->u."
|
||||
|
||||
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
|
||||
where
|
||||
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; }")
|
||||
(const [])
|
||||
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"
|
||||
|
||||
-- | 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.
|
||||
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
|
||||
where
|
||||
doc = "converts a `" ++ typeName ++ "` to a string."
|
||||
doc = "converts a `" ++ (show concreteStructTy) ++ "` to a string."
|
||||
template =
|
||||
Template
|
||||
(FuncTy [RefTy concreteStructTy (VarTy "q")] StringTy StaticLifetimeTy)
|
||||
(\(FuncTy [RefTy structTy _] StringTy _) -> toTemplate $ "String $NAME(" ++ tyToCLambdaFix structTy ++ " *p)")
|
||||
( \(FuncTy [RefTy (StructTy _ _) _] StringTy _) ->
|
||||
tokensForStr typeEnv env typeName cases concreteStructTy
|
||||
tokensForStr typeEnv env (show name) cases concreteStructTy
|
||||
)
|
||||
( \(FuncTy [RefTy (StructTy _ _) _] StringTy _) ->
|
||||
concatMap
|
||||
@ -179,12 +200,12 @@ concreteStr _ _ _ _ _ _ = error "concretestr"
|
||||
|
||||
-- | The template for the 'str' function for a generic deftype.
|
||||
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
|
||||
where
|
||||
path = SymPath insidePath strOrPrn
|
||||
t = FuncTy [RefTy originalStructTy (VarTy "q")] StringTy StaticLifetimeTy
|
||||
docs = "stringifies a `" ++ show typeName ++ "`."
|
||||
docs = "stringifies a `" ++ show originalStructTy ++ "`."
|
||||
templateCreator = TemplateCreator $
|
||||
\typeEnv env ->
|
||||
Template
|
||||
@ -195,7 +216,7 @@ genericStr insidePath originalStructTy@(StructTy (ConcreteNameTy typeName) _) ca
|
||||
( \(FuncTy [RefTy concreteStructTy@(StructTy _ _) _] StringTy _) ->
|
||||
let mappings = unifySignatures originalStructTy concreteStructTy
|
||||
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 _) ->
|
||||
let mappings = unifySignatures originalStructTy concreteStructTy
|
||||
@ -307,10 +328,10 @@ genericSumtypeDelete pathStrings originalStructTy cases =
|
||||
|
||||
-- | The template for the 'delete' function of a concrete sumtype
|
||||
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
|
||||
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
|
||||
(FuncTy [VarTy "p"] UnitTy StaticLifetimeTy)
|
||||
@ -381,10 +402,10 @@ genericSumtypeCopy pathStrings originalStructTy cases =
|
||||
|
||||
-- | The template for the 'copy' function of a concrete sumtype
|
||||
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
|
||||
where
|
||||
doc = "copies a `" ++ typeName ++ "`."
|
||||
doc = "copies a `" ++ (show structTy) ++ "`."
|
||||
template =
|
||||
Template
|
||||
(FuncTy [RefTy (VarTy "p") (VarTy "q")] (VarTy "p") StaticLifetimeTy)
|
||||
|
@ -5,6 +5,7 @@ module SymPath
|
||||
mangle,
|
||||
pathToC,
|
||||
consPath,
|
||||
fromStrings,
|
||||
)
|
||||
where
|
||||
|
||||
@ -89,3 +90,9 @@ pathToC (SymPath modulePath name) =
|
||||
consPath :: [String] -> SymPath -> SymPath
|
||||
consPath qualifyers (SymPath 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
|
||||
| UninhabitedConstructor Ty XObj Int Int
|
||||
| InconsistentKinds String [XObj]
|
||||
| FailedToAddLambdaStructToTyEnv SymPath XObj
|
||||
|
||||
instance Show TypeError where
|
||||
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
|
||||
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."
|
||||
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 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]
|
||||
(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."]
|
||||
(FailedToAddLambdaStructToTyEnv path xobj) ->
|
||||
[ machineReadableInfoFromXObj fppl xobj ++ "Failed to add the lambda: " ++ show path ++ " represented by struct: "
|
||||
++ pretty xobj
|
||||
++ " to the type environment."
|
||||
]
|
||||
_ ->
|
||||
[show err]
|
||||
|
||||
@ -473,7 +483,7 @@ keysInEnvEditDistance path@(SymPath (p : ps) name) env distance =
|
||||
case Map.lookup p (envBindings env) of
|
||||
Just (Binder _ xobj) ->
|
||||
case xobj of
|
||||
(XObj (Mod modEnv) _ _) -> keysInEnvEditDistance (SymPath ps name) modEnv distance
|
||||
(XObj (Mod modEnv _) _ _) -> keysInEnvEditDistance (SymPath ps name) modEnv distance
|
||||
_ -> []
|
||||
Nothing ->
|
||||
case envParent env of
|
||||
|
14
src/Types.hs
14
src/Types.hs
@ -26,6 +26,7 @@ module Types
|
||||
getStructName,
|
||||
getPathFromStructName,
|
||||
getNameFromStructName,
|
||||
getStructPath,
|
||||
promoteNumber,
|
||||
)
|
||||
where
|
||||
@ -60,7 +61,7 @@ data Ty
|
||||
| RefTy Ty Ty -- second Ty is the lifetime
|
||||
| StaticLifetimeTy
|
||||
| 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
|
||||
| MacroTy
|
||||
| DynamicTy -- the type of dynamic functions (used in REPL and macros)
|
||||
@ -179,7 +180,7 @@ instance Show Ty where
|
||||
show InterfaceTy = "Interface"
|
||||
show (StructTy s []) = show s
|
||||
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 (RefTy r lt) =
|
||||
-- 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)
|
||||
lambdaEnvTy :: Ty
|
||||
lambdaEnvTy = StructTy (ConcreteNameTy "LambdaEnv") []
|
||||
lambdaEnvTy = StructTy (ConcreteNameTy (SymPath [] "LambdaEnv")) []
|
||||
|
||||
createStructName :: [String] -> String -> String
|
||||
createStructName path name = intercalate "." (path ++ [name])
|
||||
|
||||
getStructName :: Ty -> String
|
||||
getStructName (StructTy (ConcreteNameTy name) _) = name
|
||||
getStructName (StructTy (ConcreteNameTy spath) _) = show spath
|
||||
getStructName (StructTy (VarTy name) _) = name
|
||||
getStructName _ = ""
|
||||
|
||||
@ -354,6 +355,11 @@ getPathFromStructName structName =
|
||||
getNameFromStructName :: String -> String
|
||||
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!
|
||||
promoteNumber :: Ty -> Ty -> Ty
|
||||
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 (StructTy s []) = tyToCManglePtr False s
|
||||
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 TypeTy = err "types"
|
||||
f MacroTy = err "macros"
|
||||
|
13
src/Util.hs
13
src/Util.hs
@ -1,5 +1,6 @@
|
||||
module Util where
|
||||
|
||||
import Data.Bifunctor
|
||||
import Data.List
|
||||
import Data.Maybe (fromMaybe)
|
||||
import qualified Map
|
||||
@ -116,3 +117,15 @@ intToArgName 7 = "t"
|
||||
intToArgName 8 = "s"
|
||||
intToArgName 9 = "r"
|
||||
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.List (nubBy, (\\))
|
||||
import Data.Maybe (fromJust)
|
||||
import Lookup
|
||||
import qualified Env as E
|
||||
import Obj
|
||||
import TypeError
|
||||
import TypePredicates
|
||||
@ -104,21 +104,19 @@ canBeUsedAsMemberType typeEnv typeVariables ty xobj =
|
||||
_ -> Left (InvalidMemberType ty xobj)
|
||||
where
|
||||
checkStruct :: Ty -> [Ty] -> Either TypeError ()
|
||||
checkStruct (ConcreteNameTy "Array") [innerType] =
|
||||
checkStruct (ConcreteNameTy (SymPath [] "Array")) [innerType] =
|
||||
canBeUsedAsMemberType typeEnv typeVariables innerType xobj
|
||||
>> pure ()
|
||||
checkStruct (ConcreteNameTy n) vars =
|
||||
case lookupBinder (SymPath lookupPath name) (getTypeEnv typeEnv) of
|
||||
Just (Binder _ (XObj (Lst (XObj (ExternalType _) _ _ : _)) _ _)) ->
|
||||
checkStruct (ConcreteNameTy (SymPath _ name)) vars =
|
||||
case E.getTypeBinder typeEnv name of
|
||||
Right (Binder _ (XObj (Lst (XObj (ExternalType _) _ _ : _)) _ _)) ->
|
||||
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
|
||||
Just (Binder _ (XObj (Lst (XObj (DefSumtype t) _ _ : _)) _ _)) ->
|
||||
Right (Binder _ (XObj (Lst (XObj (DefSumtype t) _ _ : _)) _ _)) ->
|
||||
checkInhabitants t >> foldM (\_ typ -> canBeUsedAsMemberType typeEnv typeVariables typ xobj) () vars
|
||||
_ -> Left (NotAmongRegisteredTypes ty xobj)
|
||||
where
|
||||
lookupPath = getPathFromStructName n
|
||||
name = getNameFromStructName n
|
||||
checkInhabitants :: Ty -> Either TypeError ()
|
||||
checkInhabitants (StructTy _ vs) =
|
||||
if length vs == length vars
|
||||
|
@ -116,16 +116,16 @@ testConstr10 =
|
||||
|
||||
testConstr11 =
|
||||
assertSolution
|
||||
[Constraint (PointerTy (VarTy "a")) (PointerTy (StructTy (ConcreteNameTy "Monkey") [])) x x x OrdNo]
|
||||
[("a", (StructTy (ConcreteNameTy "Monkey") []))]
|
||||
[Constraint (PointerTy (VarTy "a")) (PointerTy (StructTy (ConcreteNameTy (SymPath [] "Monkey")) [])) x x x OrdNo]
|
||||
[("a", (StructTy (ConcreteNameTy (SymPath [] "Monkey")) []))]
|
||||
|
||||
testConstr12 =
|
||||
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
|
||||
]
|
||||
[ ("t1", (PointerTy (StructTy (ConcreteNameTy "Array") [IntTy]))),
|
||||
("t2", (StructTy (ConcreteNameTy "Array") [IntTy]))
|
||||
[ ("t1", (PointerTy (StructTy (ConcreteNameTy (SymPath [] "Array")) [IntTy]))),
|
||||
("t2", (StructTy (ConcreteNameTy (SymPath [] "Array")) [IntTy]))
|
||||
]
|
||||
|
||||
testConstr13 =
|
||||
@ -144,36 +144,36 @@ testConstr13 =
|
||||
-- Struct types
|
||||
testConstr20 =
|
||||
assertSolution
|
||||
[ Constraint t0 (StructTy (ConcreteNameTy "Vector") [t1]) x x x OrdNo,
|
||||
Constraint t0 (StructTy (ConcreteNameTy "Vector") [IntTy]) x x x OrdNo
|
||||
[ Constraint t0 (StructTy (ConcreteNameTy (SymPath [] "Vector")) [t1]) 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 =
|
||||
assertSolution
|
||||
[ Constraint t1 (StructTy (ConcreteNameTy "Array") [t2]) x x x OrdNo,
|
||||
Constraint t1 (StructTy (ConcreteNameTy "Array") [t3]) x x x OrdNo,
|
||||
[ Constraint t1 (StructTy (ConcreteNameTy (SymPath [] "Array")) [t2]) x x x OrdNo,
|
||||
Constraint t1 (StructTy (ConcreteNameTy (SymPath [] "Array")) [t3]) x x x OrdNo,
|
||||
Constraint t3 BoolTy x x x OrdNo
|
||||
]
|
||||
[ ("t1", (StructTy (ConcreteNameTy "Array") [BoolTy])),
|
||||
[ ("t1", (StructTy (ConcreteNameTy (SymPath [] "Array")) [BoolTy])),
|
||||
("t2", BoolTy),
|
||||
("t3", BoolTy)
|
||||
]
|
||||
|
||||
testConstr22 =
|
||||
assertSolution
|
||||
[ Constraint t1 (StructTy (ConcreteNameTy "Array") [t2]) x x x OrdNo,
|
||||
Constraint t2 (StructTy (ConcreteNameTy "Array") [t3]) x x x OrdNo,
|
||||
[ Constraint t1 (StructTy (ConcreteNameTy (SymPath [] "Array")) [t2]) x x x OrdNo,
|
||||
Constraint t2 (StructTy (ConcreteNameTy (SymPath [] "Array")) [t3]) x x x OrdNo,
|
||||
Constraint t3 FloatTy x x x OrdNo
|
||||
]
|
||||
[ ("t1", (StructTy (ConcreteNameTy "Array") [(StructTy (ConcreteNameTy "Array") [FloatTy])])),
|
||||
("t2", (StructTy (ConcreteNameTy "Array") [FloatTy])),
|
||||
[ ("t1", (StructTy (ConcreteNameTy (SymPath [] "Array")) [(StructTy (ConcreteNameTy (SymPath [] "Array")) [FloatTy])])),
|
||||
("t2", (StructTy (ConcreteNameTy (SymPath [] "Array")) [FloatTy])),
|
||||
("t3", FloatTy)
|
||||
]
|
||||
|
||||
testConstr23 =
|
||||
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 t2 FloatTy x x x OrdNo
|
||||
]
|
||||
@ -182,7 +182,7 @@ testConstr24 =
|
||||
assertUnificationFailure
|
||||
[ Constraint t2 FloatTy 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]
|
||||
@ -219,10 +219,10 @@ testConstr33 =
|
||||
|
||||
testConstr34 =
|
||||
assertSolution
|
||||
[ Constraint (VarTy "a") (StructTy (ConcreteNameTy "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 (VarTy "a") (StructTy (ConcreteNameTy (SymPath [] "Pair")) [(VarTy "x0"), (VarTy "y0")]) 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")),
|
||||
("y0", (VarTy "y0")),
|
||||
("x1", (VarTy "x0")),
|
||||
@ -232,10 +232,10 @@ testConstr34 =
|
||||
-- Same as testConstr34, except everything is wrapped in refs
|
||||
testConstr35 =
|
||||
assertSolution
|
||||
[ Constraint (RefTy (VarTy "a") (VarTy "lt0")) (RefTy (StructTy (ConcreteNameTy "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 (VarTy "a") (VarTy "lt0")) (RefTy (StructTy (ConcreteNameTy (SymPath [] "Pair")) [(VarTy "x0"), (VarTy "y0")]) (VarTy "lt1")) 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")),
|
||||
("y0", (VarTy "y0")),
|
||||
("x1", (VarTy "x0")),
|
||||
|
@ -1,6 +1,6 @@
|
||||
module TestLookup where
|
||||
|
||||
import qualified Lookup as Lookup
|
||||
import Env as E
|
||||
import qualified Map
|
||||
import Obj
|
||||
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
|
||||
|
||||
assertNotFound :: Maybe Binder -> Test
|
||||
assertNotFound Nothing = TestCase (assertBool "assertNotFound" True) -- Better way?
|
||||
assertNotFound :: Either EnvironmentError Binder -> Test
|
||||
assertNotFound (Left _) = TestCase (assertBool "assertNotFound" True) -- Better way?
|
||||
assertNotFound _ = TestCase (assertBool "assertNotFound" False)
|
||||
|
||||
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
|
||||
(deftype C []))
|
||||
(use Wrap2)
|
||||
(use Wrap)
|
||||
|
||||
(deftype B [])
|
||||
|
||||
(deftest test
|
||||
(assert-equal test
|
||||
@ -23,4 +26,8 @@
|
||||
"(Wrap2.C)"
|
||||
(ref (str (ref (C))))
|
||||
"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