carp-lang/Carp
1
1
Fork 0
mirror of https://github.com/carp-lang/Carp.git synced 2024-08-15 16:20:40 +03:00
Code Issues Projects Releases Wiki Activity

Refactor: clean up Env module, store type environments in modules (#1207)

Browse Source 
* 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:
Scott Olsen 2021-05-19 13:20:48 -04:00 committed by GitHub
parent f90d677993
commit e1943b29a9
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
37 changed files with 1800 additions and 1095 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
CarpHask.cabal
View File

@ -34,7 +34,6 @@ library
Info,
InitialTypes,
Interfaces,
Lookup,
Managed,
Map,
Meta,

2
headerparse/Main.hs
View File

@ -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

59
src/ArrayTemplates.hs
View File

@ -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?

2
src/AssignTypes.hs
View File

@ -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...)

28
src/Commands.hs
View File

@ -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"

136
src/Concretize.hs
View File

@ -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
View File

@ -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
View File

@ -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
View File

@ -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
View File

@ -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
View File

@ -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

21
src/Expand.hs
View File

@ -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 $

4
src/GenerateConstraints.hs
View File

@ -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)

44
src/InitialTypes.hs
View File

@ -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)]

61
src/Interfaces.hs
View File

@ -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
View File

@ -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
View File

@ -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
View File

@ -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

32
src/Polymorphism.hs
View File

@ -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

34
src/PrimitiveError.hs
View File

@ -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) =

521
src/Primitives.hs
View File

@ -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
View File

@ -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) =

1
src/Reify.hs
View File

@ -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

2
src/RenderDocs.hs
View File

@ -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

43
src/Scoring.hs
View File

@ -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

23
src/StartingEnv.hs
View File

@ -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

2
src/StaticArrayTemplates.hs
View File

@ -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 =

71
src/Sumtypes.hs
View File

@ -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)

7
src/SymPath.hs
View File

@ -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)

12
src/TypeError.hs
View File

@ -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
View File

@ -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

2
src/TypesToC.hs
View File

@ -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
View File

@ -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

16
src/Validate.hs
View File

@ -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

46
test/TestConstraints.hs
View File

@ -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")),

8
test/TestLookup.hs
View File

@ -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")))

7
test/deftype.carp
View File

@ -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.")
)