carp-lang/Carp
1
1
Fork 0
mirror of https://github.com/carp-lang/Carp.git synced 2024-09-17 08:27:45 +03:00
Code Issues Projects Releases Wiki Activity

Address unused matches. (#1019)

Browse Source
This commit is contained in:
jacereda 2020-11-25 22:12:57 +01:00 committed by GitHub
parent f6386c6b70
commit cb39a6a0c3
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
27 changed files with 283 additions and 283 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
CarpHask.cabal
View File

@ -14,7 +14,7 @@ extra-source-files: README.md
cabal-version: >=1.10
library
ghc-options: -Wall -Wno-name-shadowing -Wno-unused-matches -Wno-incomplete-patterns
ghc-options: -Wall -Wno-name-shadowing -Wno-incomplete-patterns
hs-source-dirs: src
exposed-modules: Info,
Obj,

26
src/ArrayTemplates.hs
View File

@ -30,7 +30,7 @@ templateEMap =
," return a;"
,"}"
])
(\(FuncTy [RefTy t@(FuncTy fArgTys fRetTy _) _, arrayType] _ _) ->
(\(FuncTy [RefTy t@(FuncTy fArgTys fRetTy _) _, _] _ _) ->
[defineFunctionTypeAlias t, defineFunctionTypeAlias (FuncTy (lambdaEnvTy : fArgTys) fRetTy StaticLifetimeTy)])
templateShrinkCheck :: String -> String
@ -73,7 +73,7 @@ templateEFilter = defineTypeParameterizedTemplate templateCreator path t docs
, " return a;"
, "}"
])
(\(FuncTy [RefTy ft@(FuncTy fArgTys@[RefTy insideType _] BoolTy _) _, arrayType] _ _) ->
(\(FuncTy [RefTy ft@(FuncTy fArgTys@[RefTy insideType _] BoolTy _) _, _] _ _) ->
[defineFunctionTypeAlias ft, defineFunctionTypeAlias (FuncTy (lambdaEnvTy : fArgTys) BoolTy StaticLifetimeTy)] ++
depsForDeleteFunc typeEnv env insideType)
@ -97,7 +97,7 @@ templatePushBack =
," return a;"
,"}"
])
(\(FuncTy [arrayType, _] _ _) -> [])
(\(FuncTy [_, _] _ _) -> [])
templatePushBackBang :: (String, Binder)
templatePushBackBang =
@ -118,7 +118,7 @@ templatePushBackBang =
," (($a*)aRef->data)[aRef->len - 1] = value;"
,"}"
])
(\(FuncTy [arrayType, _] _ _) -> [])
(\(FuncTy [_, _] _ _) -> [])
templatePopBack :: (String, Binder)
templatePopBack = defineTypeParameterizedTemplate templateCreator path t docs
@ -131,7 +131,7 @@ templatePopBack = defineTypeParameterizedTemplate templateCreator path t docs
Template
t
(const (toTemplate "Array $NAME(Array a)"))
(\(FuncTy [arrayType@(StructTy _ [insideTy])] _ _) ->
(\(FuncTy [(StructTy _ [insideTy])] _ _) ->
let deleteElement = insideArrayDeletion typeEnv env insideTy
in toTemplate (unlines
["$DECL { "
@ -164,7 +164,7 @@ templatePopBackBang =
," return ret;"
,"}"
])
(\(FuncTy [arrayType] _ _) -> [])
(\(FuncTy [_] _ _) -> [])
templateNth :: (String, Binder)
@ -181,7 +181,7 @@ templateNth =
," assert(n < a.len);"
," return &((($t*)a.data)[n]);"
,"}"])
(\(FuncTy [RefTy arrayType _, _] _ _) ->
(\(FuncTy [RefTy _ _, _] _ _) ->
[])
templateRaw :: (String, Binder)
@ -191,7 +191,7 @@ templateRaw = defineTemplate
"returns an array `a` as a raw pointer—useful for interacting with C."
(toTemplate "$t* $NAME (Array a)")
(toTemplate "$DECL { return a.data; }")
(\(FuncTy [arrayType] _ _) -> [])
(\(FuncTy [_] _ _) -> [])
templateUnsafeRaw :: (String, Binder)
templateUnsafeRaw = defineTemplate
@ -200,7 +200,7 @@ templateUnsafeRaw = defineTemplate
"returns an array `a` as a raw pointer—useful for interacting with C."
(toTemplate "$t* $NAME (Array* a)")
(toTemplate "$DECL { return a->data; }")
(\(FuncTy [RefTy arrayType _] _ _) -> [])
(\(FuncTy [RefTy _ _] _ _) -> [])
templateAset :: (String, Binder)
templateAset = defineTypeParameterizedTemplate templateCreator path t docs
@ -254,7 +254,7 @@ templateAsetUninitializedBang = defineTypeParameterizedTemplate templateCreator
t = FuncTy [RefTy (StructTy (ConcreteNameTy "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 $
\typeEnv env ->
\_ _ ->
Template
t
(const (toTemplate "void $NAME (Array *aRef, int n, $t newValue)"))
@ -316,7 +316,7 @@ templateDeleteArray = defineTypeParameterizedTemplate templateCreator path t doc
[TokDecl, TokC "{\n"] ++
deleteTy typeEnv env arrayType ++
[TokC "}\n"])
(\(FuncTy [arrayType@(StructTy (ConcreteNameTy "Array") [insideType])] UnitTy _) ->
(\(FuncTy [(StructTy (ConcreteNameTy "Array") [insideType])] UnitTy _) ->
depsForDeleteFunc typeEnv env insideType)
deleteTy :: TypeEnv -> Env -> Ty -> [Token]
@ -393,7 +393,7 @@ copyTy typeEnv env (StructTy (ConcreteNameTy "Array") [innerType]) =
case findFunctionForMember typeEnv env "delete"
(typesDeleterFunctionType innerType) ("Inside array.", innerType) of
FunctionFound _ -> True
FunctionNotFound msg -> False
FunctionNotFound _ -> False
FunctionIgnored -> False
copyTy _ _ _ = []
@ -418,7 +418,7 @@ templateStrArray = defineTypeParameterizedTemplate templateCreator path t docs
[TokDecl, TokC " {\n"] ++
strTy typeEnv env arrayType ++
[TokC "}\n"])
(\(FuncTy [RefTy arrayType@(StructTy (ConcreteNameTy "Array") [insideType]) _] StringTy _) ->
(\(FuncTy [RefTy (StructTy (ConcreteNameTy "Array") [insideType]) _] StringTy _) ->
depsForPrnFunc typeEnv env insideType)
path = SymPath ["Array"] "str"
t = FuncTy [RefTy (StructTy (ConcreteNameTy "Array") [VarTy "a"]) (VarTy "q")] StringTy StaticLifetimeTy

36
src/Commands.hs
View File

@ -156,7 +156,7 @@ commandProjectGetConfig :: CommandCallback
commandProjectGetConfig ctx [xobj@(XObj (Str key) _ _)] =
let proj = contextProj ctx
xstr s = XObj s (Just dummyInfo) (Just StringTy)
getVal ctx proj = case key of
getVal _ proj = case key of
"cflag" -> Right $ Str $ show $ projectCFlags proj
"libflag" -> Right $ Str $ show $ projectLibFlags proj
"pkgconfigflag" -> Right $ Arr $ xstr . Str <$> projectPkgConfigFlags proj
@ -189,13 +189,13 @@ commandProjectGetConfig ctx [faultyKey] =
-- | Command for exiting the REPL/compiler
commandQuit :: CommandCallback
commandQuit ctx args =
commandQuit ctx _ =
do _ <- liftIO exitSuccess
pure (ctx, dynamicNil)
-- | Command for printing the generated C output (in out/main.c)
commandCat :: CommandCallback
commandCat ctx args = do
commandCat ctx _ = do
let outDir = projectOutDir (contextProj ctx)
outMain = outDir </> "main.c"
liftIO $ do callCommand ("cat -n " ++ outMain)
@ -203,7 +203,7 @@ commandCat ctx args = do
-- | Command for running the executable generated by the 'build' command.
commandRunExe :: CommandCallback
commandRunExe ctx args = do
commandRunExe ctx _ = do
let proj = contextProj ctx
outDir = projectOutDir proj
quoted x = "\"" ++ x ++ "\""
@ -219,7 +219,7 @@ commandRunExe ctx args = do
-- | Command for building the project, producing an executable binary or a shared library.
commandBuild :: Bool -> Context -> [XObj] -> IO (Context, Either EvalError XObj)
commandBuild shutUp ctx args = do
commandBuild shutUp ctx _ = do
let env = contextGlobalEnv ctx
typeEnv = contextTypeEnv ctx
proj = contextProj ctx
@ -280,7 +280,7 @@ setProjectCanExecute value ctx =
-- | Command for printing all the bindings in the current environment.
commandListBindings :: CommandCallback
commandListBindings ctx args =
commandListBindings ctx _ =
liftIO $ do putStrLn "Types:\n"
putStrLn (prettyEnvironment (getTypeEnv (contextTypeEnv ctx)))
putStrLn "\nGlobal environment:\n"
@ -290,7 +290,7 @@ commandListBindings ctx args =
-- | Command for printing information about the current project.
commandProject :: CommandCallback
commandProject ctx args = do
commandProject ctx _ = do
liftIO (print (contextProj ctx))
pure (ctx, dynamicNil)
@ -386,8 +386,8 @@ commandCdr ctx [x] =
commandLast :: CommandCallback
commandLast ctx [x] =
pure $ case x of
XObj (Lst lst@(x:xs)) _ _ -> (ctx, Right (last lst))
XObj (Arr arr@(x:xs)) _ _ -> (ctx, Right (last arr))
XObj (Lst lst@(_:_)) _ _ -> (ctx, Right (last lst))
XObj (Arr arr@(_:_)) _ _ -> (ctx, Right (last arr))
_ -> evalError ctx "Applying 'last' to non-list or empty list." (info x)
commandAllButLast :: CommandCallback
@ -480,7 +480,7 @@ commandEq ctx [a, b] =
cmp' elem (Right True) = cmp elem
commandComp :: (Number -> Number -> Bool) -> String -> CommandCallback
commandComp op opname ctx [XObj (Num aTy aNum) _ _, XObj (Num bTy bNum) _ _] | aTy == bTy = pure $ (ctx, Right (boolToXObj (op aNum bNum)))
commandComp op _ ctx [XObj (Num aTy aNum) _ _, XObj (Num bTy bNum) _ _] | aTy == bTy = pure $ (ctx, Right (boolToXObj (op aNum bNum)))
commandComp _ opname ctx [a, b] = pure $ evalError ctx ("Can't compare (" ++ opname ++ ") " ++ pretty a ++ " with " ++ pretty b) (info a)
@ -559,7 +559,7 @@ commandSymFrom ctx [x@(XObj (Sym _ _) _ _)] = pure (ctx, Right x)
commandSymFrom ctx [XObj (Str s) i t] = pure (ctx, Right $ XObj (sFrom_ s) i t)
commandSymFrom ctx [XObj (Pattern s) i t] = pure (ctx, Right $ XObj (sFrom_ s) i t)
commandSymFrom ctx [XObj (Chr c) i t] = pure (ctx, Right $ XObj (sFrom_ (show c)) i t)
commandSymFrom ctx [XObj n@(Num _ v) i t] = pure (ctx, Right $ XObj (sFrom_ (show v)) i t)
commandSymFrom ctx [XObj (Num _ v) i t] = pure (ctx, Right $ XObj (sFrom_ (show v)) i t)
commandSymFrom ctx [XObj (Bol b) i t] = pure (ctx, Right $ XObj (sFrom_ (show b)) i t)
commandSymFrom ctx [x] =
pure $ evalError ctx ("Can’t call `from` with " ++ pretty x) (info x)
@ -590,7 +590,7 @@ commandPathAbsolute ctx [a] =
commandArith :: (Number -> Number -> Number) -> String -> CommandCallback
commandArith op opname ctx [XObj (Num aTy aNum) _ _, XObj (Num bTy bNum) _ _] | aTy == bTy =
commandArith op _ ctx [XObj (Num aTy aNum) _ _, XObj (Num bTy bNum) _ _] | aTy == bTy =
pure $ (ctx, Right (XObj (Num aTy (op aNum bNum)) (Just dummyInfo) (Just aTy)))
commandArith _ opname ctx [a, b] = pure $ evalError ctx ("Can't call " ++ opname ++ " with " ++ pretty a ++ " and " ++ pretty b) (info a)
@ -613,7 +613,7 @@ commandStr ctx xs =
pure (ctx, Right (XObj (Str (join (map f xs))) (Just dummyInfo) (Just StringTy)))
-- | TODO: Is there a better function to call here than some exceptions + 'pretty'?
where f (XObj (Str s) _ _) = s
f (XObj (Sym path mode) _ _) = show path
f (XObj (Sym path _) _ _) = show path
f x = escape $ pretty x
escape [] = []
escape ('\\':y) = "\\\\" ++ escape y
@ -667,9 +667,9 @@ commandSaveDocsInternal ctx [modulePath] = do
x ->
pure (evalError ctx ("Invalid arg to save-docs-internal (expected list of symbols): " ++ pretty x) (info modulePath))
where getEnvironmentBinderForDocumentation :: Context -> Env -> SymPath -> Either String Binder
getEnvironmentBinderForDocumentation ctx env path =
getEnvironmentBinderForDocumentation _ env path =
case lookupInEnv path env of
Just (_, foundBinder@(Binder _ (XObj (Mod foundEnv) _ _))) ->
Just (_, foundBinder@(Binder _ (XObj (Mod _) _ _))) ->
Right foundBinder
Just (_, Binder _ x) ->
Left ("I can’t generate documentation for `" ++ pretty x ++ "` because it isn’t a module")
@ -697,7 +697,7 @@ commandSexpressionInternal ctx [xobj] bol =
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))
mod@(XObj (Mod e) i t) ->
mod@(XObj (Mod e) _ _) ->
if bol
then getMod
else
@ -710,14 +710,14 @@ commandSexpressionInternal ctx [xobj] bol =
getMod
where getMod =
case (toSymbols mod) of
x@(XObj (Lst xs) i t) ->
x@(XObj (Lst _) _ _) ->
bindingSyms e (ctx, Right x)
where bindingSyms env start =
(mapM (\x -> commandSexpression ctx [x]) $
map snd $
Map.toList $ Map.map binderXObj (envBindings env))
>>= pure . foldl combine start
combine (c, (Right (XObj (Lst xs) i t))) (_ , (Right y@(XObj (Lst ys) _ _))) =
combine (c, (Right (XObj (Lst xs) i t))) (_ , (Right y@(XObj (Lst _) _ _))) =
(c, Right (XObj (Lst (xs ++ [y])) i t))
combine _ (c, (Left err)) =
(c, Left err)

62
src/Concretize.hs
View File

@ -40,9 +40,9 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
rootDefinitionPath = getPath root
visit :: Bool -> Level -> Env -> XObj -> State [XObj] (Either TypeError XObj)
visit allowAmbig level env xobj@(XObj (Sym _ _) _ _) = visitSymbol allowAmbig env xobj
visit allowAmbig level env xobj@(XObj (MultiSym _ _) _ _) = visitMultiSym allowAmbig env xobj
visit allowAmbig level env xobj@(XObj (InterfaceSym _) _ _) = visitInterfaceSym allowAmbig env xobj
visit allowAmbig _ env xobj@(XObj (Sym _ _) _ _) = visitSymbol allowAmbig env xobj
visit allowAmbig _ env xobj@(XObj (MultiSym _ _) _ _) = visitMultiSym allowAmbig env xobj
visit allowAmbig _ env xobj@(XObj (InterfaceSym _) _ _) = visitInterfaceSym allowAmbig env xobj
visit allowAmbig level env xobj@(XObj (Lst _) i t) =
do visited <- visitList allowAmbig level env xobj
pure $ do okVisited <- visited
@ -86,7 +86,7 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
pure $ do okBody <- visitedBody
pure [defn, nameSymbol, args, okBody]
visitList _ Inside env xobj@(XObj (Lst [defn@(XObj (Defn _) _ _), nameSymbol, args@(XObj (Arr argsArr) _ _), body]) _ t) =
visitList _ Inside _ xobj@(XObj (Lst [(XObj (Defn _) _ _), _, (XObj (Arr _) _ _), _]) _ _) =
pure (Left (DefinitionsMustBeAtToplevel xobj))
-- | Fn / λ
@ -175,7 +175,7 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
pure $ do okBody <- visitedBody
pure [def, nameSymbol, okBody]
visitList _ Inside env xobj@(XObj (Lst [def@(XObj Def _ _), nameSymbol, body]) _ t) =
visitList _ Inside _ xobj@(XObj (Lst [(XObj Def _ _), _, _]) _ _) =
pure (Left (DefinitionsMustBeAtToplevel xobj))
visitList allowAmbig level env (XObj (Lst [letExpr@(XObj Let _ _), XObj (Arr bindings) bindi bindt, body]) _ _) =
@ -191,7 +191,7 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
pure $ do okVisitedValue <- visitedValue
pure [theExpr, typeXObj, okVisitedValue]
visitList allowAmbig level env matchXObj@(XObj (Lst (matchExpr@(XObj (Match _) _ _) : expr : rest)) _ _) =
visitList allowAmbig level env (XObj (Lst (matchExpr@(XObj (Match _) _ _) : expr : rest)) _ _) =
do _ <- concretizeTypeOfXObj typeEnv expr
visitedExpr <- visit allowAmbig level env expr
mapM_ (concretizeTypeOfXObj typeEnv . snd) (pairwise rest)
@ -200,7 +200,7 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
okVisitedRest <- fmap concat visitedRest
pure ([matchExpr, okVisitedExpr] ++ okVisitedRest)
visitList allowAmbig level env setXObj@(XObj (Lst [setbangExpr@(XObj SetBang _ _), variable, value]) _ _) =
visitList allowAmbig _ env (XObj (Lst [setbangExpr@(XObj SetBang _ _), variable, value]) _ _) =
do visitedValue <- visit allowAmbig Inside env value
pure $ do okVisitedValue <- visitedValue
pure [setbangExpr, variable, okVisitedValue]
@ -271,14 +271,14 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
[])
Left (Holes holes) ->
pure $ Left (HolesFound holes)
severalPaths -> pure (Right xobj)
_ -> pure (Right xobj)
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 lookupInEnv (SymPath [] name) (getTypeEnv typeEnv) of
Just (_, Binder _ (XObj (Lst [XObj (Interface interfaceSignature interfacePaths) _ _, _]) _ _)) ->
Just (_, Binder _ (XObj (Lst [XObj (Interface _ interfacePaths) _ _, _]) _ _)) ->
let Just actualType = t
tys = map (typeFromPath env) interfacePaths
tysToPathsDict = zip tys interfacePaths
@ -298,7 +298,7 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
pure (Right xobj) -- No exact match of types
[(theType, singlePath)] -> replace theType singlePath -- Found an exact match, will ignore any "half matched" functions that might have slipped in.
_ -> pure (Left (SeveralExactMatches xobj name actualType severalPaths))
where replace theType singlePath =
where replace _ singlePath =
let normalSymbol = XObj (Sym singlePath (LookupGlobal CarpLand AFunction)) i t -- TODO: Is it surely AFunction here? Could be AVariable as well...!?
in visitSymbol allowAmbig env -- $ trace ("Replacing symbol " ++ pretty xobj ++ " with type " ++ show theType ++ " to single path " ++ show singlePath)
normalSymbol
@ -343,7 +343,7 @@ collectCapturedVars root = removeDuplicates (map decreaseCaptureLevel (visit roo
(Lst _) -> visitList xobj
(Arr _) -> visitArray xobj
-- TODO: Static Arrays!
sym@(Sym path (LookupLocal (Capture _))) -> [XObj sym (Just dummyInfo) (ty xobj)]
sym@(Sym _ (LookupLocal (Capture _))) -> [XObj sym (Just dummyInfo) (ty xobj)]
_ -> []
visitList :: XObj -> [XObj]
@ -372,7 +372,7 @@ concretizeTypeOfXObj typeEnv (XObj _ _ (Just t)) =
Right t -> do modify (t ++)
pure (Right ())
Left err -> pure (Left err)
concretizeTypeOfXObj _ xobj = pure (Right ())
concretizeTypeOfXObj _ _ = pure (Right ())
-- | Find all the concrete deps of a type.
concretizeType :: TypeEnv -> Ty -> Either TypeError [XObj]
@ -412,7 +412,7 @@ concretizeType env (RefTy rt _) =
concretizeType env rt
concretizeType env (PointerTy pt) =
concretizeType env pt
concretizeType _ t =
concretizeType _ _ =
Right [] -- ignore all other types
-- | Given an generic struct type and a concrete version of it, generate all dependencies needed to use the concrete one.
@ -487,7 +487,7 @@ replaceGenericTypeSymbolsOnMembers mappings memberXObjs =
concatMap (\(v, t) -> [v, replaceGenericTypeSymbols mappings t]) (pairwise memberXObjs)
replaceGenericTypeSymbols :: Map.Map String Ty -> XObj -> XObj
replaceGenericTypeSymbols mappings xobj@(XObj (Sym (SymPath pathStrings name) _) i t) =
replaceGenericTypeSymbols mappings xobj@(XObj (Sym (SymPath _ name) _) _ _) =
let Just perhapsTyVar = xobjToTy xobj
in if isFullyGenericType perhapsTyVar
then case Map.lookup name mappings of
@ -501,7 +501,7 @@ replaceGenericTypeSymbols mappings (XObj (Arr arr) i t) =
replaceGenericTypeSymbols _ xobj = xobj
replaceGenericTypeSymbolsOnCase :: Map.Map String Ty -> XObj -> XObj
replaceGenericTypeSymbolsOnCase mappings singleCase@(XObj (Lst (caseName : caseMembers)) i t) =
replaceGenericTypeSymbolsOnCase mappings (XObj (Lst (caseName : caseMembers)) i t) =
XObj (Lst (caseName : map replacer caseMembers)) i t
where replacer memberXObj =
replaceGenericTypeSymbols mappings memberXObj
@ -509,9 +509,9 @@ replaceGenericTypeSymbolsOnCase mappings singleCase@(XObj (Lst (caseName : caseM
-- `Done` is a Sym, not a Lst. DepsForCase, like this function
-- expects and only matches on a Lst, so we convert the problematic cases to a
-- canonical form. (see `depsForCase` above
replaceGenericTypeSymbolsOnCase mappings nakedCase@(XObj (Sym (SymPath _ _) _) i t) =
replaceGenericTypeSymbolsOnCase _ nakedCase@(XObj (Sym (SymPath _ _) _) i t) =
XObj (Lst [nakedCase, XObj (Arr []) i t]) i t -- NOTE: This transformation is done in some other pass too, just returning 'nakedCase' would be fine here.
replaceGenericTypeSymbolsOnCase mappings unknownCase = unknownCase -- TODO: error out?
replaceGenericTypeSymbolsOnCase _ unknownCase = unknownCase -- TODO: error out?
-- | Get the type of a symbol at a given path.
typeFromPath :: Env -> SymPath -> Ty
@ -587,7 +587,7 @@ concretizeDefinition allowAmbiguity typeEnv globalEnv visitedDefinitions definit
in Right (withNewType, [])
XObj (Lst [XObj (Instantiate template) _ _, _]) _ _ ->
Right (instantiateTemplate newPath concreteType template)
err ->
_ ->
Left $ CannotConcretize definition
-- | Find ALL functions with a certain name, matching a type signature.
@ -674,7 +674,7 @@ findFunctionForMember typeEnv env functionName functionType (memberName, memberT
-- | TODO: should this be the default and 'findFunctionForMember' be the specific one
findFunctionForMemberIncludePrimitives :: TypeEnv -> Env -> String -> Ty -> (String, Ty) -> FunctionFinderResult
findFunctionForMemberIncludePrimitives typeEnv env functionName functionType (memberName, memberType) =
findFunctionForMemberIncludePrimitives _ env functionName functionType (memberName, _) =
case allFunctionsWithNameAndSignature env functionName functionType of
[] -> FunctionNotFound ("Can't find any '" ++ functionName ++ "' function for member '" ++
memberName ++ "' of type " ++ show functionType)
@ -747,7 +747,7 @@ manageMemory typeEnv globalEnv root =
_ ->
pure (Right xobj)
case r of
Right ok -> do MemState _ _ m <- get
Right ok -> do MemState _ _ _ <- get
r <- checkThatRefTargetIsAlive ok -- $ trace ("CHECKING " ++ pretty ok ++ " : " ++ showMaybeTy (ty xobj) ++ ", mappings: " ++ prettyLifetimeMappings m) $
addToLifetimesMappingsIfRef True ok -- (***)
pure r
@ -876,7 +876,7 @@ manageMemory typeEnv globalEnv root =
visitedValue <- visit value
_ <- unmanage value -- The assigned value can't be used anymore
MemState managed deps postLifetimes <- get
MemState managed _ _ <- get
-- Delete the value previously stored in the variable, if it's still alive
let deleters = case createDeleter okCorrectVariable of
Just d -> Set.fromList [d]
@ -884,7 +884,7 @@ manageMemory typeEnv globalEnv root =
newVariable =
case okMode of
Symbol -> error "How to handle this?"
LookupLocal captureMode ->
LookupLocal _ ->
if Set.size (Set.intersection managed deleters) == 1 -- The variable is still alive
then variable { info = setDeletersOnInfo varInfo deleters }
else variable -- don't add the new info = no deleter
@ -906,7 +906,7 @@ manageMemory typeEnv globalEnv root =
Left (CannotSetVariableFromLambda variable setbangExpr)
_ ->
do okValue <- visitedValue
okOwnsTheVarBefore <- ownsTheVarBefore -- Force Either to fail
_ <- ownsTheVarBefore -- Force Either to fail
pure (XObj (Lst [setbangExpr, newVariable, okValue]) i t)
[addressExpr@(XObj Address _ _), value] ->
@ -958,8 +958,8 @@ manageMemory typeEnv globalEnv root =
put (MemState (postDeleters \\ diff) deps postLifetimes) -- Same as just pre deleters, right?!
pure $ do okExpr <- visitedExpr
okBody <- visitedBody
okExpr2 <- visitedExpr2 -- This evaluates the second visit so that it actually produces the error
okBody2 <- visitedBody2 -- And this one too. Laziness FTW.
_ <- visitedExpr2 -- This evaluates the second visit so that it actually produces the error
_ <- visitedBody2 -- And this one too. Laziness FTW.
let newInfo = setDeletersOnInfo i diff
-- Also need to set deleters ON the expression (for first run through the loop)
XObj objExpr objInfo objTy = okExpr
@ -1110,8 +1110,8 @@ manageMemory typeEnv globalEnv root =
visitList _ = error "Must visit list."
visitMatchCase :: (XObj, XObj) -> State MemState (Either TypeError ((Set.Set Deleter, (XObj, XObj)), [XObj]))
visitMatchCase (lhs@(XObj _ lhsInfo _), rhs@XObj{}) =
do MemState preDeleters preDeps preLifetimes <- get
visitMatchCase (lhs@(XObj _ _ _), rhs@XObj{}) =
do MemState preDeleters _ _ <- get
_ <- visitCaseLhs lhs
visitedRhs <- visit rhs
_ <- unmanage rhs
@ -1145,7 +1145,7 @@ manageMemory typeEnv globalEnv root =
Just (RefTy _ (VarTy lt)) ->
do m@(MemState _ _ lifetimes) <- get
case Map.lookup lt lifetimes of
Just existing ->
Just _ ->
--trace ("\nThere is already a mapping for '" ++ pretty xobj ++ "' from the lifetime '" ++ lt ++ "' to " ++ show existing ++ ", won't add " ++ show (makeLifetimeMode xobj)) $
pure ()
Nothing ->
@ -1153,7 +1153,7 @@ manageMemory typeEnv globalEnv root =
put $ --(trace $ "\nExtended lifetimes mappings for '" ++ pretty xobj ++ "' with " ++ show lt ++ " => " ++ show (makeLifetimeMode xobj) ++ " at " ++ prettyInfoFromXObj xobj ++ ":\n" ++ prettyLifetimeMappings lifetimes') $
m { memStateLifetimes = lifetimes' }
pure ()
Just notThisType ->
Just _ ->
--trace ("Won't add to mappings! " ++ pretty xobj ++ " : " ++ show notThisType ++ " at " ++ prettyInfoFromXObj xobj) $
pure ()
_ ->
@ -1227,7 +1227,7 @@ manageMemory typeEnv globalEnv root =
pure (name, okExpr)
visitArg :: XObj -> State MemState (Either TypeError XObj)
visitArg xobj@(XObj _ _ (Just t)) =
visitArg xobj@(XObj _ _ (Just _)) =
do afterVisit <- visit xobj
case afterVisit of
Right okAfterVisit -> do addToLifetimesMappingsIfRef True okAfterVisit
@ -1315,7 +1315,7 @@ manageMemory typeEnv globalEnv root =
XObj (Sym _ (LookupGlobal _ _)) _ _ -> True
_ -> False
in if not isGlobalVariable && not (isGlobalFunc xobj) && isManaged typeEnv t && not (isExternalType typeEnv t) && not (isSymbolThatCaptures xobj) -- TODO: The 'isManaged typeEnv t' boolean check should be removed!
then do MemState deleters deps lifetimes <- get
then do MemState deleters _ _ <- get
pure $ case deletersMatchingXObj xobj deleters of
[] -> Left (GettingReferenceToUnownedValue xobj)
[_] -> pure ()

8
src/Constraints.hs
View File

@ -61,7 +61,7 @@ data UnificationFailure = UnificationFailure { unificationFailure ::Constraint
deriving (Eq, Show)
instance Show Constraint where
show (Constraint a b xa xb ctx ord) = "{" ++ show a ++ " == " ++ show b ++ " (ord " ++ show ord ++ ")} " -- ++ show (fmap infoLine (info xa)) ++ ", " ++ show (fmap infoLine (info xb)) ++ " in " ++ show ctx
show (Constraint a b _ _ _ ord) = "{" ++ show a ++ " == " ++ show b ++ " (ord " ++ show ord ++ ")} " -- ++ show (fmap infoLine (info xa)) ++ ", " ++ show (fmap infoLine (info xb)) ++ " in " ++ show ctx
-- Finds the symbol with the "lowest name" (first in alphabetical order)
recursiveLookup :: TypeMappings -> String -> Maybe Ty
@ -196,7 +196,7 @@ checkConflictInternal mappings constraint name otherTy =
Just (VarTy _) -> ok
Just (StructTy (VarTy _) structTyVars) ->
case otherTy of
StructTy otherStructName otherTyVars -> foldM solveOneInternal mappings (zipWith (mkConstraint OrdStruct xobj1 xobj2 ctx) structTyVars otherTyVars)
StructTy _ otherTyVars -> foldM solveOneInternal mappings (zipWith (mkConstraint OrdStruct xobj1 xobj2 ctx) structTyVars otherTyVars)
VarTy _ -> Right mappings
_ -> Left (UnificationFailure constraint mappings)
Just (StructTy (ConcreteNameTy structName) structTyVars) ->
@ -211,7 +211,7 @@ checkConflictInternal mappings constraint name otherTy =
FuncTy otherArgTys otherRetTy otherLifetimeTy ->
do m <- foldM solveOneInternal mappings (zipWith (mkConstraint OrdFunc xobj1 xobj2 ctx) argTys otherArgTys)
case solveOneInternal m (mkConstraint OrdFunc xobj1 xobj2 ctx retTy otherRetTy) of
Right ok -> solveOneInternal m (mkConstraint OrdFunc xobj1 xobj2 ctx lifetimeTy otherLifetimeTy)
Right _ -> solveOneInternal m (mkConstraint OrdFunc xobj1 xobj2 ctx lifetimeTy otherLifetimeTy)
Left err -> Left err
VarTy _ -> Right mappings
_ -> Left (UnificationFailure constraint mappings)
@ -271,4 +271,4 @@ resolveFully mappings varName = Right (Map.insert varName (fullResolve (VarTy va
fullLookup visited funcTy@(FuncTy argTys retTy ltTy) =
let newVisited = Set.insert funcTy visited
in FuncTy (map (fullLookup newVisited) argTys) (fullLookup newVisited retTy) (fullLookup newVisited ltTy)
fullLookup visited x = x
fullLookup _ x = x

28
src/Deftype.hs
View File

@ -106,7 +106,7 @@ templatesForSingleMember typeEnv env insidePath p@(StructTy (ConcreteNameTy type
-- | The template for getters of a deftype.
templateGetter :: String -> Ty -> Template
templateGetter member UnitTy =
templateGetter _ UnitTy =
Template
(FuncTy [RefTy (VarTy "p") (VarTy "q")] UnitTy StaticLifetimeTy)
(const (toTemplate "void $NAME($(Ref p) p)"))
@ -129,7 +129,7 @@ templateGetter member memberTy =
-- | The template for setters of a concrete deftype.
templateSetter :: TypeEnv -> Env -> String -> Ty -> Template
templateSetter typeEnv env memberName UnitTy =
templateSetter _ _ _ UnitTy =
Template
(FuncTy [VarTy "p", VarTy "t"] (VarTy "p") StaticLifetimeTy)
(const (toTemplate "$p $NAME($p p)"))
@ -182,7 +182,7 @@ templateGenericSetter pathStrings originalStructTy@(StructTy (ConcreteNameTy typ
-- | The template for mutating setters of a deftype.
templateMutatingSetter :: TypeEnv -> Env -> String -> Ty -> Template
templateMutatingSetter typeEnv env memberName UnitTy =
templateMutatingSetter _ _ _ UnitTy =
Template
(FuncTy [RefTy (VarTy "p") (VarTy "q"), VarTy "t"] UnitTy StaticLifetimeTy)
(const (toTemplate "void $NAME($p* pRef)"))
@ -231,7 +231,7 @@ templateGenericMutatingSetter pathStrings originalStructTy@(StructTy (ConcreteNa
-- | The template for updater functions of a deftype.
-- | (allows changing a variable by passing an transformation function).
templateUpdater :: String -> Ty -> Template
templateUpdater member UnitTy =
templateUpdater _ UnitTy =
Template
(FuncTy [VarTy "p", RefTy (FuncTy [] UnitTy (VarTy "fq")) (VarTy "q")] (VarTy "p") StaticLifetimeTy)
(const (toTemplate "$p $NAME($p p, Lambda *updater)")) -- "Lambda" used to be: $(Fn [t] t)
@ -269,7 +269,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) typeVariables) membersXObjs =
concreteInit allocationMode originalStructTy@(StructTy (ConcreteNameTy typeName) _) membersXObjs =
Template
(FuncTy (map snd (memberXObjsToPairs membersXObjs)) (VarTy "p") StaticLifetimeTy)
(\(FuncTy _ concreteStructTy _) ->
@ -292,7 +292,7 @@ genericInit allocationMode pathStrings originalStructTy@(StructTy (ConcreteNameT
t = FuncTy (map snd (memberXObjsToPairs membersXObjs)) originalStructTy StaticLifetimeTy
docs = "creates a `" ++ typeName ++ "`."
templateCreator = TemplateCreator $
\typeEnv env ->
\typeEnv _ ->
Template
(FuncTy (map snd (memberXObjsToPairs membersXObjs)) (VarTy "p") StaticLifetimeTy)
(\(FuncTy _ concreteStructTy _) ->
@ -325,7 +325,7 @@ tokensForInit allocationMode typeName membersXObjs =
, " return instance;"
, "}"]
where assignments [] = " instance.__dummy = 0;"
assignments xobjs = go $ unitless
assignments _ = go $ unitless
where go [] = ""
go xobjs = joinLines $ memberAssignment allocationMode . fst <$> xobjs
unitless = remove (isUnit . snd) (memberXObjsToPairs membersXObjs)
@ -358,19 +358,19 @@ binderForStrOrPrn typeEnv env insidePath structTy@(StructTy (ConcreteNameTy type
-- | 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 strOrPrn =
concreteStr typeEnv env concreteStructTy@(StructTy (ConcreteNameTy typeName) _) memberPairs _ =
Template
(FuncTy [RefTy concreteStructTy (VarTy "q")] StringTy StaticLifetimeTy)
(\(FuncTy [RefTy structTy _] StringTy _) -> toTemplate $ "String $NAME(" ++ tyToCLambdaFix structTy ++ " *p)")
(\(FuncTy [RefTy structTy@(StructTy _ concreteMemberTys) _] StringTy _) ->
(\(FuncTy [RefTy (StructTy _ _) _] StringTy _) ->
tokensForStr typeEnv env typeName memberPairs concreteStructTy)
(\ft@(FuncTy [RefTy structTy@(StructTy _ concreteMemberTys) (VarTy "q")] StringTy _) ->
(\(FuncTy [RefTy (StructTy _ _) (VarTy "q")] StringTy _) ->
concatMap (depsOfPolymorphicFunction typeEnv env [] "prn" . typesStrFunctionType typeEnv)
(remove isFullyGenericType (map snd memberPairs)))
-- | The template for the 'str' function for a generic deftype.
genericStr :: [String] -> Ty -> [XObj] -> String -> (String, Binder)
genericStr pathStrings originalStructTy@(StructTy (ConcreteNameTy typeName) varTys) membersXObjs strOrPrn =
genericStr pathStrings originalStructTy@(StructTy (ConcreteNameTy typeName) _) membersXObjs strOrPrn =
defineTypeParameterizedTemplate templateCreator path t docs
where path = SymPath pathStrings strOrPrn
t = FuncTy [RefTy originalStructTy (VarTy "q")] StringTy StaticLifetimeTy
@ -381,12 +381,12 @@ genericStr pathStrings originalStructTy@(StructTy (ConcreteNameTy typeName) varT
t
(\(FuncTy [RefTy concreteStructTy _] StringTy _) ->
toTemplate $ "String $NAME(" ++ tyToCLambdaFix concreteStructTy ++ " *p)")
(\(FuncTy [RefTy concreteStructTy@(StructTy _ concreteMemberTys) _] StringTy _) ->
(\(FuncTy [RefTy concreteStructTy@(StructTy _ _) _] StringTy _) ->
let mappings = unifySignatures originalStructTy concreteStructTy
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
memberPairs = memberXObjsToPairs correctedMembers
in tokensForStr typeEnv env typeName memberPairs concreteStructTy)
(\ft@(FuncTy [RefTy concreteStructTy@(StructTy _ concreteMemberTys) _] StringTy _) ->
(\ft@(FuncTy [RefTy concreteStructTy@(StructTy _ _) _] StringTy _) ->
let mappings = unifySignatures originalStructTy concreteStructTy
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
memberPairs = memberXObjsToPairs correctedMembers
@ -416,7 +416,7 @@ 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@(StructTy (ConcreteNameTy name) _) =
calculateStructStrSize typeEnv env members (StructTy (ConcreteNameTy name) _) =
" int size = snprintf(NULL, 0, \"(%s )\", \"" ++ name ++ "\");\n" ++
unlines (map (memberPrnSize typeEnv env) members)

64
src/Emit.hs
View File

@ -122,18 +122,18 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
Break -> error (show (DontVisitObj xobj))
While -> error (show (DontVisitObj xobj))
Do -> error (show (DontVisitObj xobj))
e@(Deftype _) -> error (show (DontVisitObj xobj))
e@(DefSumtype _) -> error (show (DontVisitObj xobj))
(Deftype _) -> error (show (DontVisitObj xobj))
(DefSumtype _) -> error (show (DontVisitObj xobj))
Mod _ -> error (show (CannotEmitModKeyword xobj))
External _ -> error (show (CannotEmitExternal xobj))
ExternalType _ -> error (show (DontVisitObj xobj))
e@(Command _) -> error (show (DontVisitObj xobj))
e@(Primitive _) -> error (show (DontVisitObj xobj))
e@(Deftemplate _) -> error (show (DontVisitObj xobj))
e@(Instantiate _) -> error (show (DontVisitObj xobj))
e@(Defalias _) -> error (show (DontVisitObj xobj))
e@(MultiSym _ _) -> error (show (DontVisitObj xobj))
e@(InterfaceSym _) -> error (show (DontVisitObj xobj))
(Command _) -> error (show (DontVisitObj xobj))
(Primitive _) -> error (show (DontVisitObj xobj))
(Deftemplate _) -> error (show (DontVisitObj xobj))
(Instantiate _) -> error (show (DontVisitObj xobj))
(Defalias _) -> error (show (DontVisitObj xobj))
(MultiSym _ _) -> error (show (DontVisitObj xobj))
(InterfaceSym _) -> error (show (DontVisitObj xobj))
Address -> error (show (DontVisitObj xobj))
SetBang -> error (show (DontVisitObj xobj))
Macro -> error (show (DontVisitObj xobj))
@ -142,7 +142,7 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
The -> error (show (DontVisitObj xobj))
Ref -> error (show (DontVisitObj xobj))
Deref -> error (show (DontVisitObj xobj))
e@(Interface _ _) -> error (show (DontVisitObj xobj))
(Interface _ _) -> error (show (DontVisitObj xobj))
visitStr' indent str i =
-- | This will allocate a new string every time the code runs:
@ -164,7 +164,7 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
escapeString = foldr escaper ""
visitSymbol :: Int -> XObj -> State EmitterState String
visitSymbol _ xobj@(XObj (Sym _ (LookupGlobalOverride overrideWithName)) _ t) =
visitSymbol _ (XObj (Sym _ (LookupGlobalOverride overrideWithName)) _ _) =
pure overrideWithName
visitSymbol indent xobj@(XObj sym@(Sym path lookupMode) (Just i) t) =
let Just t' = t
@ -179,7 +179,7 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
LookupLocal (Capture _) -> "_env->" ++ pathToC path
_ -> pathToC path
visitSymbol _ xobj@(XObj (Sym path _) Nothing _) = error ("Symbol missing info: " ++ show xobj)
visitSymbol _ xobj@(XObj (Sym _ _) Nothing _) = error ("Symbol missing info: " ++ show xobj)
visitSymbol _ _ = error "Not a symbol."
visitList :: Int -> XObj -> State EmitterState String
@ -207,7 +207,7 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
pure ""
-- Fn / λ
[XObj (Fn name set) _ _, XObj (Arr argList) _ _, body] ->
[XObj (Fn name set) _ _, XObj (Arr _) _ _, _] ->
do let retVar = freshVar i
capturedVars = Set.toList set
Just callback = name
@ -306,7 +306,7 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
exprTy = exprTyNotFixed
tagCondition :: String -> String -> Ty -> XObj -> [String]
tagCondition var periodOrArrow caseTy (caseLhs@(XObj (Lst (XObj (Sym firstPath@(SymPath _ caseName) _) _ _ : caseMatchers)) caseLhsInfo _)) =
tagCondition var periodOrArrow caseTy ((XObj (Lst (XObj (Sym (SymPath _ caseName) _) _ _ : caseMatchers)) _ _)) =
-- HACK! The function 'removeSuffix' ignores the type specialisation of the tag name and just uses the base name
-- A better idea is to not specialise the names, which happens when calling 'concretize' on the lhs
-- This requires a bunch of extra machinery though, so this will do for now...
@ -321,11 +321,11 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
tempVarToAvoidClash = freshVar exprInfo ++ "_temp";
emitCaseMatcher :: (String, String) -> String -> XObj -> Integer -> State EmitterState ()
emitCaseMatcher (periodOrArrow, ampersandOrNot) caseName (XObj (Sym path _) i t) index =
emitCaseMatcher (periodOrArrow, ampersandOrNot) caseName (XObj (Sym path _) _ t) index =
let Just tt = t
in appendToSrc (addIndent indent' ++ tyToCLambdaFix tt ++ " " ++ pathToC path ++ " = "
++ ampersandOrNot ++ tempVarToAvoidClash ++ periodOrArrow ++ "u." ++ mangle caseName ++ ".member" ++ show index ++ ";\n")
emitCaseMatcher periodOrArrow caseName xobj@(XObj (Lst (XObj (Sym (SymPath _ innerCaseName) _) _ _ : xs)) i t) index =
emitCaseMatcher periodOrArrow caseName (XObj (Lst (XObj (Sym (SymPath _ innerCaseName) _) _ _ : xs)) _ _) index =
zipWithM_ (\x i -> emitCaseMatcher periodOrArrow (caseName ++ ".member" ++ show i ++ ".u." ++ removeSuffix innerCaseName) x index) xs ([0..] :: [Int])
emitCaseMatcher _ _ xobj _ =
error ("Failed to emit case matcher for: " ++ pretty xobj)
@ -340,9 +340,9 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
_ -> error ("Failed to remove outer ref on type " ++ show t)
emitCase :: String -> Bool -> (XObj, XObj) -> State EmitterState ()
emitCase exprVar isFirst (caseLhs@(XObj (Lst (XObj Ref _ _ : caseMatchers)) _ _), caseExpr) =
emitCase _ _ (caseLhs@(XObj (Lst (XObj Ref _ _ : _)) _ _), _) =
error ("Can't emit case matchers for refs: " ++ pretty caseLhs)
emitCase exprVar isFirst (caseLhs@(XObj (Lst (XObj (Sym firstPath@(SymPath _ caseName@(firstLetter : _)) _) _ _ : caseMatchers)) caseLhsInfo _), caseExpr) =
emitCase exprVar isFirst (caseLhs@(XObj (Lst (XObj (Sym (SymPath _ caseName@(_ : _)) _) _ _ : caseMatchers)) caseLhsInfo _), caseExpr) =
-- A list of things, beginning with a tag
do appendToSrc (addIndent indent)
unless isFirst (appendToSrc "else ")
@ -443,9 +443,9 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
do valueVar <- visit indent value
let properVariableName =
case variable of
(XObj (Lst (XObj (Sym (SymPath _ "copy") _) _ _ : symObj@(XObj (Sym sym _) _ _) : _)) _ _) -> "*" ++ pathToC sym
(XObj (Lst (XObj (Sym (SymPath _ "copy") _) _ _ : (XObj (Sym sym _) _ _) : _)) _ _) -> "*" ++ pathToC sym
(XObj (Sym sym _) _ _) -> pathToC sym
v -> error (show (CannotSet variable))
_ -> error (show (CannotSet variable))
Just varInfo = info variable
--appendToSrc (addIndent indent ++ "// " ++ show (length (infoDelete varInfo)) ++ " deleters for " ++ properVariableName ++ ":\n")
delete indent varInfo
@ -659,7 +659,7 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
visitStaticArray _ _ = error "Must visit static array!"
visitStaticArrayElement :: Int -> String -> Ty -> Int -> XObj -> State EmitterState ()
visitStaticArrayElement indent arrayDataVar innerTy index xobj =
visitStaticArrayElement indent arrayDataVar _ index xobj =
do visited <- visit indent xobj
appendToSrc (addIndent indent ++ arrayDataVar ++ "[" ++ show index ++ "] = " ++ visited ++ ";\n")
pure ()
@ -714,7 +714,7 @@ memberToDecl indent (memberName, memberType) =
Nothing -> error ("Invalid memberType: " ++ show memberType)
defStructToDeclaration :: Ty -> SymPath -> [XObj] -> String
defStructToDeclaration structTy@(StructTy typeName typeVariables) path rest =
defStructToDeclaration structTy@(StructTy _ _) _ rest =
let indent = indentAmount
typedefCaseToMemberDecl :: XObj -> State EmitterState [()]
@ -733,7 +733,7 @@ defStructToDeclaration structTy@(StructTy typeName typeVariables) path rest =
else emitterSrc (execState visit (EmitterState ""))
defSumtypeToDeclaration :: Ty -> [XObj] -> String
defSumtypeToDeclaration sumTy@(StructTy typeName typeVariables) rest =
defSumtypeToDeclaration sumTy@(StructTy _ _) rest =
let indent = indentAmount
visit = do appendToSrc "typedef struct {\n"
@ -749,18 +749,18 @@ defSumtypeToDeclaration sumTy@(StructTy typeName typeVariables) rest =
emitSumtypeCase :: Int -> XObj -> State EmitterState ()
emitSumtypeCase indent (XObj (Lst [XObj (Sym (SymPath [] caseName) _) _ _, XObj (Arr []) _ _]) _ _) =
appendToSrc (addIndent indent ++ "// " ++ caseName ++ "\n")
emitSumtypeCase indent xobj@(XObj (Lst [XObj (Sym (SymPath [] caseName) _) _ _, XObj (Arr memberTys) _ _]) _ _) =
emitSumtypeCase indent (XObj (Lst [XObj (Sym (SymPath [] caseName) _) _ _, XObj (Arr memberTys) _ _]) _ _) =
do appendToSrc (addIndent indent ++ "struct {\n")
let members = zipWith (\anonName tyXObj -> (anonName, tyXObj)) anonMemberSymbols (remove (isUnit . fromJust . xobjToTy) memberTys)
mapM_ (memberToDecl (indent + indentAmount)) members
appendToSrc (addIndent indent ++ "} " ++ caseName ++ ";\n")
emitSumtypeCase indent xobj@(XObj (Sym (SymPath [] caseName) _) _ _) =
emitSumtypeCase indent (XObj (Sym (SymPath [] caseName) _) _ _) =
appendToSrc (addIndent indent ++ "// " ++ caseName ++ "\n")
emitSumtypeCaseTagDefinition :: (Int, XObj) -> State EmitterState ()
emitSumtypeCaseTagDefinition (tagIndex, xobj@(XObj (Lst [XObj (Sym (SymPath [] caseName) _) _ _, _]) _ _)) =
emitSumtypeCaseTagDefinition (tagIndex, (XObj (Lst [XObj (Sym (SymPath [] caseName) _) _ _, _]) _ _)) =
appendToSrc ("#define " ++ tagName sumTy caseName ++ " " ++ show tagIndex ++ "\n")
emitSumtypeCaseTagDefinition (tagIndex, xobj@(XObj (Sym (SymPath [] caseName) _) _ _)) =
emitSumtypeCaseTagDefinition (tagIndex, (XObj (Sym (SymPath [] caseName) _) _ _)) =
appendToSrc ("#define " ++ tagName sumTy caseName ++ " " ++ show tagIndex ++ "\n")
in if isTypeGeneric sumTy
@ -787,7 +787,7 @@ toDeclaration (Binder meta xobj@(XObj (Lst xobjs) _ t)) =
in "" ++ tyToCLambdaFix t' ++ " " ++ pathToC path ++ ";\n"
XObj (Deftype t) _ _ : XObj (Sym path _) _ _ : rest ->
defStructToDeclaration t path rest
XObj (DefSumtype t) _ _ : XObj (Sym path _) _ _ : rest ->
XObj (DefSumtype t) _ _ : XObj (Sym _ _) _ _ : rest ->
defSumtypeToDeclaration t rest
XObj (Deftemplate _) _ _ : _ ->
""
@ -912,21 +912,21 @@ checkForUnresolvedSymbols = visit
_ -> pure ()
visitList :: XObj -> Either ToCError ()
visitList (XObj (Lst xobjs) i t) =
visitList (XObj (Lst xobjs) _ _) =
case mapM visit xobjs of
Left e -> Left e
Right _ -> pure ()
visitList _ = error "The function 'visitList' only accepts XObjs with lists in them."
visitArray :: XObj -> Either ToCError ()
visitArray (XObj (Arr xobjs) i t) =
visitArray (XObj (Arr xobjs) _ _) =
case mapM visit xobjs of
Left e -> Left e
Right _ -> pure ()
visitArray _ = error "The function 'visitArray' only accepts XObjs with arrays in them."
visitStaticArray :: XObj -> Either ToCError ()
visitStaticArray (XObj (StaticArr xobjs) i t) =
visitStaticArray (XObj (StaticArr xobjs) _ _) =
case mapM visit xobjs of
Left e -> Left e
Right _ -> pure ()
@ -948,5 +948,5 @@ wrapInInitFunction with_core src =
removeSuffix :: String -> String
removeSuffix [] = []
removeSuffix [c] = [c]
removeSuffix ('_' : '_' : cs) = []
removeSuffix ('_' : '_' : _) = []
removeSuffix (c:cs) = c : removeSuffix cs

72
src/Eval.hs
View File

@ -97,7 +97,7 @@ eval ctx xobj@(XObj o i t) preference =
_ -> do (nctx, res) <- annotateWithinContext False ctx xobj
pure $ case res of
Left e -> (nctx, Left e)
Right (val, deps) -> (nctx, Right val)
Right (val, _) -> (nctx, Right val)
where
resolveDef (XObj (Lst [XObj DefDynamic _ _, _, value]) _ _) = value
resolveDef (XObj (Lst [XObj LetDef _ _, _, value]) _ _) = value
@ -122,7 +122,7 @@ eval ctx xobj@(XObj o i t) preference =
("I didn’t understand this `if`.\n\n Got:\n```\n" ++ pretty xobj ++
"\n```\n\nExpected the form:\n```\n(if cond then else)\n```\n") (info xobj))
[XObj (Defn _) _ _, name, args@(XObj (Arr a) _ _), body] ->
[XObj (Defn _) _ _, name, args@(XObj (Arr a) _ _), _] ->
case obj name of
(Sym (SymPath [] _) _) ->
if all isUnqualifiedSym a
@ -134,7 +134,7 @@ eval ctx xobj@(XObj o i t) preference =
("`defn` identifiers must be unqualified symbols, but it got `" ++
pretty name ++ "`") (info xobj))
[XObj (Defn _) _ _, name, invalidArgs, _] ->
[XObj (Defn _) _ _, _, invalidArgs, _] ->
pure (evalError ctx
("`defn` requires an array of symbols as argument list, but it got `" ++
pretty invalidArgs ++ "`") (info xobj))
@ -146,7 +146,7 @@ eval ctx xobj@(XObj o i t) preference =
"\n\nIs it valid? Every `defn` needs to follow the form `(defn name [arg] body)`.")
(info defn))
[def@(XObj Def _ _), name, expr] ->
[(XObj Def _ _), name, _] ->
if isUnqualifiedSym name
then specialCommandDefine ctx xobj
else pure (evalError ctx
@ -165,7 +165,7 @@ eval ctx xobj@(XObj o i t) preference =
"\n\nIs it valid? Every `the` needs to follow the form `(the type expression)`.")
(info xobj))
[XObj Let _ _, XObj (Arr bindings) bindi bindt, body]
[XObj Let _ _, XObj (Arr bindings) _ _, body]
| odd (length bindings) -> pure (evalError ctx
("Uneven number of forms in `let`: " ++ pretty xobj)
(info xobj)) -- Unreachable?
@ -199,11 +199,11 @@ eval ctx xobj@(XObj o i t) preference =
pure $ Right (newCtx {contextInternalEnv=Just (envInsertAt e (SymPath [] n) binder)})
Left err -> pure $ Left err
l@[XObj Fn{} _ _, args@(XObj (Arr a) _ _), f] ->
l@[XObj Fn{} _ _, args@(XObj (Arr a) _ _), _] ->
pure $ if all isUnqualifiedSym a
then (ctx, Right (XObj (Closure (XObj (Lst l) i t) (CCtx ctx)) i t))
else evalError ctx ("`fn` requires all arguments to be unqualified symbols, but it got `" ++ pretty args ++ "`") (info args)
XObj (Closure (XObj (Lst [XObj (Fn _ _) _ _, XObj (Arr params) _ _, body]) _ _) (CCtx c)) i _:args ->
XObj (Closure (XObj (Lst [XObj (Fn _ _) _ _, XObj (Arr params) _ _, body]) _ _) (CCtx c)) _ _:args ->
case checkArity params args of
Left err -> pure (evalError ctx err (info xobj))
Right () ->
@ -233,10 +233,10 @@ eval ctx xobj@(XObj o i t) preference =
(ctx', res) <- apply ctx body params args
case res of
Right xobj -> macroExpand ctx' xobj
Left err -> pure (ctx, res)
Left _ -> pure (ctx, res)
XObj (Lst [XObj (Command callback) _ _, _, _]) _ _:args ->
do (newCtx, evaledArgs) <- foldlM successiveEval (ctx, Right []) args
do (_, evaledArgs) <- foldlM successiveEval (ctx, Right []) args
case evaledArgs of
Right okArgs -> getCommand callback ctx okArgs
Left err -> pure (ctx, Left err)
@ -259,7 +259,7 @@ eval ctx xobj@(XObj o i t) preference =
pure (popFrame newCtx', res)
x -> pure (newCtx, x)
x@(XObj sym@(Sym s _) i _):args -> do
x@(XObj (Sym _ _) i _):args -> do
(newCtx, f) <- eval ctx x preference
case f of
Right fun -> do
@ -284,7 +284,7 @@ eval ctx xobj@(XObj o i t) preference =
[XObj Address _ _, value] ->
specialCommandAddress ctx value
[] -> pure (ctx, dynamicNil)
x -> do
_ -> do
pure (evalError ctx ("I did not understand the form `" ++ pretty xobj ++ "`") (info xobj))
checkArity params args =
let la = length args
@ -323,8 +323,8 @@ macroExpand ctx xobj =
pure (newCtx, do ok <- expanded
Right (XObj (StaticArr ok) i t))
XObj (Lst [XObj (Lst (XObj Macro _ _:_)) _ _]) _ _ -> evalDynamic ctx xobj
XObj (Lst (x@(XObj sym@(Sym s _) _ _):args)) i t -> do
(newCtx, f) <- evalDynamic ctx x
XObj (Lst (x@(XObj (Sym _ _) _ _):args)) i t -> do
(_, f) <- evalDynamic ctx x
case f of
Right m@(XObj (Lst (XObj Macro _ _:_)) _ _) -> do
(newCtx', res) <- evalDynamic ctx (XObj (Lst (m:args)) i t)
@ -359,7 +359,7 @@ apply ctx@Context{contextInternalEnv=internal} body params args =
("I didn’t understand this macro’s argument split, got `" ++
joinWith "," allParams ++
"`, but expected exactly one `:rest` separator.") Nothing)
where callWith env proper rest = do
where callWith _ proper rest = do
let n = length proper
insideEnv = Env Map.empty internal Nothing [] InternalEnv 0
insideEnv' = foldl' (\e (p, x) -> extendEnv e p x) insideEnv
@ -482,7 +482,7 @@ catcher ctx exception =
Check -> exitSuccess
specialCommandWith :: Context -> XObj -> SymPath -> [XObj] -> IO (Context, Either EvalError XObj)
specialCommandWith ctx xobj path forms = do
specialCommandWith ctx _ path forms = do
let env = contextEnv ctx
useThese = envUseModules env
env' = if path `elem` useThese then env else env { envUseModules = path : useThese }
@ -506,10 +506,10 @@ specialCommandDefine ctx xobj =
specialCommandAddress :: Context -> XObj -> IO (Context, Either EvalError XObj)
specialCommandAddress ctx xobj =
case xobj of
XObj (Sym path _) _ _ ->
XObj (Sym _ _) _ _ ->
do (newCtx, result) <- annotateWithinContext False ctx xobj
case result of
Right (annXObj, annDeps) -> return (newCtx, Right annXObj)
Right (annXObj, _) -> return (newCtx, Right annXObj)
Left err ->
return (ctx, Left err)
_ -> return (evalError ctx ("Can't get the address of non-symbol " ++ pretty xobj) (info xobj))
@ -535,8 +535,8 @@ getSigFromDefnOrDef ctx globalEnv fppl xobj@(XObj _ i t) =
let pathStrings = contextPath ctx
path = (getPath xobj)
fullPath = case path of
(SymPath [] n) -> consPath pathStrings path
(SymPath quals n) -> path
(SymPath [] _) -> consPath pathStrings path
(SymPath _ _) -> path
metaData = existingMeta globalEnv (XObj (Sym fullPath Symbol) i t)
in case Meta.get "sig" metaData of
Just foundSignature ->
@ -559,7 +559,7 @@ annotateWithinContext qualifyDefn ctx xobj = do
case sig of
Left err -> pure (ctx, Left err)
Right okSig -> do
(ctxAfterExpansion, expansionResult) <- expandAll evalDynamic ctx xobj
(_, expansionResult) <- expandAll evalDynamic ctx xobj
case expansionResult of
Left err -> pure (evalError ctx (show err) Nothing)
Right expanded ->
@ -595,7 +595,7 @@ primitiveDefmodule xobj ctx@(Context env i typeEnv pathStrings proj lastInput ex
pure (popModulePath ctxAfterModuleAdditions{contextInternalEnv=i}, res) -- TODO: propagate errors...
Just (_, Binder existingMeta (XObj (Lst [XObj MetaStub _ _, _]) _ _)) ->
defineIt existingMeta
Just (_, Binder _ x) ->
Just (_, Binder _ _) ->
pure (evalError ctx ("Can't redefine '" ++ moduleName ++ "' as module") (info xobj))
Nothing ->
defineIt emptyMeta
@ -605,7 +605,7 @@ primitiveDefmodule xobj ctx@(Context env i typeEnv pathStrings proj lastInput ex
Right _ -> (newCtx, dynamicNil)
where folder (ctx, r) x =
case r of
Left err -> pure (ctx, r)
Left _ -> pure (ctx, r)
Right _ -> do
(newCtx, result) <- macroExpand ctx x
case result of
@ -715,7 +715,7 @@ loadInternal ctx xobj path i reloadMode = do
_ -> "I can't find a file named: '" ++ path ++ "'") ++
"\n\nI tried interpreting the statement as a git import, but got: " ++ stderr)
(info xobj)
replaceC c s [] = []
replaceC _ _ [] = []
replaceC c s (a:b) = if a == c then s ++ replaceC c s b else a : replaceC c s b
cantLoadSelf ctx path =
case contextExecMode ctx of
@ -796,7 +796,7 @@ loadFilesExt loadCmd ctxStart filesToLoad = foldM folder ctxStart filesToLoad
-- | Command for reloading all files in the project (= the files that has been loaded before).
commandReload :: CommandCallback
commandReload ctx args = do
commandReload ctx _ = do
let paths = projectFiles (contextProj ctx)
f :: Context -> (FilePath, ReloadMode) -> IO Context
f context (_, Frozen) | not (projectForceReload (contextProj context)) = pure context
@ -870,11 +870,11 @@ primitiveDefdynamic _ ctx [XObj (Sym (SymPath [] name) _) _ _, value] = do
Left err -> pure (newCtx, Left err)
Right evaledBody ->
dynamicOrMacroWith newCtx (\path -> [XObj DefDynamic Nothing Nothing, XObj (Sym path Symbol) Nothing Nothing, evaledBody]) DynamicTy name value
primitiveDefdynamic _ ctx [notName, body] =
primitiveDefdynamic _ ctx [notName, _] =
pure (evalError ctx ("`defndynamic` expected a name as first argument, but got " ++ pretty notName) (info notName))
specialCommandSet :: Context -> [XObj] -> IO (Context, Either EvalError XObj)
specialCommandSet ctx [x@(XObj (Sym path@(SymPath mod n) _) _ _), value] = do
specialCommandSet ctx [(XObj (Sym path@(SymPath mod n) _) _ _), value] = do
(newCtx, result) <- evalDynamic ctx value
case result of
Left err -> pure (newCtx, Left err)
@ -885,14 +885,14 @@ specialCommandSet ctx [x@(XObj (Sym path@(SymPath mod n) _) _ _), value] = do
Just env -> setInternal newCtx env evald
where setGlobal ctx env value =
case lookupInEnv path env of
Just (e, binder) -> do
Just (_, binder) -> do
(ctx', typedVal) <- typeCheckValueAgainstBinder ctx value binder
pure $ either (failure ctx) (success ctx') typedVal
where success c xo = (c{contextGlobalEnv = setStaticOrDynamicVar path env binder xo}, dynamicNil)
Nothing -> pure (ctx, Right value)
setInternal ctx env value =
case lookupInEnv path env of
Just (e, binder) -> do
Just (_, binder) -> do
-- TODO: Type check local bindings.
-- At the moment, let bindings are not structured the same as global defs or dynamic defs.
-- This makes calls to the type check problematic, as we cannot work against a common binding form.
@ -904,7 +904,7 @@ specialCommandSet ctx [x@(XObj (Sym path@(SymPath mod n) _) _ _), value] = do
where success c xo = (c{contextInternalEnv = Just (setStaticOrDynamicVar (SymPath [] n) env binder xo)}, dynamicNil)
-- If the def isn't found in the internal environment, check the global environment.
Nothing -> setGlobal ctx (contextGlobalEnv ctx) value
specialCommandSet ctx [notName, body] =
specialCommandSet ctx [notName, _] =
pure (evalError ctx ("`set!` expected a name as first argument, but got " ++ pretty notName) (info notName))
specialCommandSet ctx args =
pure (evalError ctx ("`set!` takes a name and a value, but got `" ++ intercalate " " (map pretty args)) (if null args then Nothing else info (head args)))
@ -919,7 +919,7 @@ typeCheckValueAgainstBinder :: Context -> XObj -> Binder -> IO (Context, (Either
typeCheckValueAgainstBinder ctx val binder = do
(ctx', typedValue) <- annotateWithinContext False ctx val
pure $ case typedValue of
Right (val', deps) -> go ctx' binderTy val'
Right (val', _) -> go ctx' binderTy val'
Left err -> (ctx', Left err)
where path = (getPath (binderXObj binder))
binderTy = ty (binderXObj binder)
@ -933,11 +933,11 @@ typeCheckValueAgainstBinder ctx val binder = do
setStaticOrDynamicVar :: SymPath -> Env -> Binder -> XObj -> Env
setStaticOrDynamicVar path env binder value =
case binder of
(Binder meta (XObj (Lst (def@(XObj Def _ _) : sym : val)) i t)) ->
(Binder meta (XObj (Lst (def@(XObj Def _ _) : sym : _)) _ t)) ->
envReplaceBinding path (Binder meta (XObj (Lst [def, sym, value]) (info value) t)) env
(Binder meta (XObj (Lst (defdy@(XObj DefDynamic _ _) : sym : val)) i t)) ->
(Binder meta (XObj (Lst (defdy@(XObj DefDynamic _ _) : sym : _)) _ _)) ->
envReplaceBinding path (Binder meta (XObj (Lst [defdy, sym, value]) (info value) (Just DynamicTy))) env
(Binder meta (XObj (Lst (lett@(XObj LetDef _ _) : sym : val)) i t)) ->
(Binder meta (XObj (Lst (lett@(XObj LetDef _ _) : sym : _)) _ t)) ->
envReplaceBinding path (Binder meta (XObj (Lst [lett, sym, value]) (info value) t)) env
-- shouldn't happen, errors are thrown at call sites.
-- TODO: Return an either here to propagate error.
@ -965,18 +965,18 @@ dynamicOrMacro ctx pat ty name params body = do
case exp of
Right expanded ->
dynamicOrMacroWith ctx' (\path -> [XObj pat Nothing Nothing, XObj (Sym path Symbol) Nothing Nothing, params, expanded]) ty name body
Left err -> pure (ctx, exp)
Left _ -> pure (ctx, exp)
primitiveDefndynamic :: Primitive
primitiveDefndynamic _ ctx [XObj (Sym (SymPath [] name) _) _ _, params, body] =
dynamicOrMacro ctx Dynamic DynamicTy name params body
primitiveDefndynamic _ ctx [notName, params, body] =
primitiveDefndynamic _ ctx [notName, _, _] =
argumentErr ctx "defndynamic" "a name" "first" notName
primitiveDefmacro :: Primitive
primitiveDefmacro _ ctx [XObj (Sym (SymPath [] name) _) _ _, params, body] =
dynamicOrMacro ctx Macro MacroTy name params body
primitiveDefmacro _ ctx [notName, params, body] =
primitiveDefmacro _ ctx [notName, _, _] =
argumentErr ctx "defmacro" "a name" "first" notName
primitiveAnd :: Primitive

12
src/Expand.hs
View File

@ -94,7 +94,7 @@ expand eval ctx xobj =
pretty xobj ++ "`)") (info xobj))
where successiveExpand (ctx, acc) (n, x) =
case acc of
Left err -> pure (ctx, acc)
Left _ -> pure (ctx, acc)
Right l -> do
(newCtx, x') <- expand eval ctx x
case x' of
@ -114,7 +114,7 @@ expand eval ctx xobj =
"I encountered an odd number of forms inside a `match`" (info xobj))
where successiveExpand (ctx, acc) (l, r) =
case acc of
Left err -> pure (ctx, acc)
Left _ -> pure (ctx, acc)
Right lst -> do
(newCtx, expandedR) <- expand eval ctx r
case expandedR of
@ -125,11 +125,11 @@ expand eval ctx xobj =
do (newCtx, expandedExpressions) <- foldlM successiveExpand (ctx, Right []) expressions
pure (newCtx, do okExpressions <- expandedExpressions
Right (XObj (Lst (doExpr : okExpressions)) i t))
[withExpr@(XObj With _ _), pathExpr@(XObj (Sym path _) _ _), expression] ->
[withExpr@(XObj With _ _), pathExpr@(XObj (Sym _ _) _ _), expression] ->
do (newCtx, expandedExpression) <- expand eval ctx expression
pure (newCtx, do okExpression <- expandedExpression
Right (XObj (Lst [withExpr, pathExpr , okExpression]) i t)) -- Replace the with-expression with just the expression!
[withExpr@(XObj With _ _), _, _] ->
[(XObj With _ _), _, _] ->
pure (evalError ctx ("I encountered the value `" ++ pretty xobj ++
"` inside a `with` at " ++ prettyInfoFromXObj xobj ++
".\n\n`with` accepts only symbols.") Nothing)
@ -143,7 +143,7 @@ expand eval ctx xobj =
implicitInit = XObj (Sym (SymPath pathToModule "init") Symbol) i t
in expand eval ctx (XObj (Lst (implicitInit : args)) (info xobj) (ty xobj))
f:args ->
do (ctx', expandedF) <- expand eval ctx f
do (_, expandedF) <- expand eval ctx f
(ctx'', expandedArgs) <- foldlM successiveExpand (ctx, Right []) args
case expandedF of
Right (XObj (Lst [XObj Dynamic _ _, _, XObj (Arr _) _ _, _]) _ _) ->
@ -187,7 +187,7 @@ expand eval ctx xobj =
successiveExpand (ctx, acc) e =
case acc of
Left err -> pure (ctx, acc)
Left _ -> pure (ctx, acc)
Right lst -> do
(newCtx, expanded) <- expand eval ctx e
pure $ case expanded of

4
src/GenerateConstraints.hs
View File

@ -15,7 +15,7 @@ import Info
-- | Will create a list of type constraints for a form.
genConstraints :: Env -> XObj -> Maybe (Ty, XObj) -> Either TypeError [Constraint]
genConstraints globalEnv root rootSig = fmap sort (gen root)
genConstraints _ root rootSig = fmap sort (gen root)
where genF xobj args body captures =
do insideBodyConstraints <- gen body
xobjType <- toEither (ty xobj) (DefnMissingType xobj)
@ -300,7 +300,7 @@ genConstraintsForCaseMatcher matchMode = gen
wholeTypeConstraint = Constraint funcVarTy fabricatedFunctionType caseName expected xobj OrdFuncAppVarTy
in pure (wholeTypeConstraint : caseNameConstraints ++ variablesConstraints)
_ -> Left (NotAFunction caseName) -- | TODO: This error could be more specific too, since it's not an actual function call.
gen x = pure []
gen _ = pure []
-- | If this is a 'match-ref' statement we want to wrap the type of *symbols* (not lists matching nested sumtypes) in a Ref type
-- | to make the type inference think they are refs.

18
src/InitialTypes.hs
View File

@ -130,12 +130,12 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
Nothing -> 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 name _) _ _) _ =
visitMultiSym _ xobj@(XObj (MultiSym _ _) _ _) _ =
do freshTy <- genVarTy
pure (Right xobj { ty = Just freshTy })
visitInterfaceSym :: Env -> XObj -> State Integer (Either TypeError XObj)
visitInterfaceSym env xobj@(XObj (InterfaceSym name) _ _) =
visitInterfaceSym _ xobj@(XObj (InterfaceSym name) _ _) =
do freshTy <- case lookupInEnv (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)
@ -192,7 +192,7 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
okArgs <- sequence visitedArgs
pure (XObj (Lst [defn, nameSymbol, XObj (Arr okArgs) argsi argst, okBody]) i funcTy)
[defn@(XObj (Defn _) _ _), XObj (Sym _ _) _ _, XObj (Arr _) _ _] -> pure (Left (NoFormsInBody xobj))
[(XObj (Defn _) _ _), XObj (Sym _ _) _ _, XObj (Arr _) _ _] -> pure (Left (NoFormsInBody xobj))
XObj defn@(Defn _) _ _ : _ -> pure (Left (InvalidObj defn xobj))
-- Fn
@ -240,7 +240,7 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
Right (XObj (Lst [letExpr, XObj (Arr okBindings) bindi bindt, okBody]) i (Just wholeExprType))
Left err -> pure (Left err)
where getDuplicate _ [] = Nothing
getDuplicate names (o@(XObj (Sym (SymPath _ x) _) _ _):y:xs) =
getDuplicate names (o@(XObj (Sym (SymPath _ x) _) _ _):_:xs) =
if x `elem` names then Just o else getDuplicate (x:names) xs
[XObj Let _ _, XObj (Arr _) _ _] ->
@ -345,11 +345,11 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
pure (XObj (Lst [refExpr, okValue]) i (Just (RefTy valueTy lt)))
-- Deref (error!)
[XObj Deref _ _, value] ->
[XObj Deref _ _, _] ->
pure (Left (CantUseDerefOutsideFunctionApplication xobj))
-- Function application with Deref
XObj (Lst [deref@(XObj Deref _ _), func]) xi xt : args ->
XObj (Lst [deref@(XObj Deref _ _), func]) xi _ : args ->
-- TODO: Remove code duplication (taken from function application below)
do t <- genVarTy
derefTy <- genVarTy
@ -432,9 +432,9 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
createBindersForCaseVariable xobj@(XObj (Sym (SymPath _ name) _) _ _) = createBinderInternal xobj name
createBindersForCaseVariable xobj@(XObj (MultiSym name _) _ _) = createBinderInternal xobj name
createBindersForCaseVariable xobj@(XObj (InterfaceSym name) _ _) = createBinderInternal xobj name
createBindersForCaseVariable xobj@(XObj (Lst lst) _ _) = do binders <- mapM createBindersForCaseVariable lst
pure (concat binders)
createBindersForCaseVariable xobj@(XObj Ref _ _) = pure []
createBindersForCaseVariable (XObj (Lst lst) _ _) = do 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)]

2
src/Interfaces.hs
View File

@ -71,7 +71,7 @@ registerInInterface ctx xobj interface =
-- | 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 -> SymPath -> Context
retroactivelyRegisterInInterface ctx interface@(SymPath _ inter) =
retroactivelyRegisterInInterface ctx interface@(SymPath _ _) =
-- TODO: Don't use error here?
either (\e -> error e) id resultCtx
where env = contextGlobalEnv ctx

6
src/Lookup.hs
View File

@ -121,7 +121,7 @@ recursiveLookupAll input lookf env =
-- | Lookup binders by name.
lookupByName :: String -> Env -> [Binder]
lookupByName name env =
let filtered = Map.filterWithKey (\k v -> k == name) (envBindings env)
let filtered = Map.filterWithKey (\k _ -> k == name) (envBindings env)
in map snd $ Map.toList filtered
-- | Lookup binders that have specified metadata.
@ -152,7 +152,7 @@ multiLookupQualified :: SymPath -> Env -> [(Env, Binder)]
multiLookupQualified (SymPath [] name) rootEnv =
-- This case is just like normal multiLookup, we have a name but no qualifyers:
multiLookup name rootEnv
multiLookupQualified path@(SymPath (p:ps) 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:
@ -290,7 +290,7 @@ envReplaceBinding s@(SymPath [] name) binder env =
case envParent env of
Just parent -> env {envParent = Just (envReplaceBinding s binder parent)}
Nothing -> env
envReplaceBinding (SymPath p name) xobj e = error "TODO: cannot replace qualified bindings"
envReplaceBinding (SymPath _ _) _ _ = error "TODO: cannot replace qualified bindings"
bindingNames :: Env -> [String]

58
src/Obj.hs
View File

@ -185,20 +185,20 @@ type Primitive = XObj -> Context -> [XObj] -> IO (Context, Either EvalError XObj
newtype PrimitiveFunctionType = PrimitiveFunction { getPrimitive :: Primitive }
instance Eq PrimitiveFunctionType where
a == b = True
_ == _ = True
instance Show PrimitiveFunctionType where
show t = "Primitive { ... }"
show _ = "Primitive { ... }"
type CommandCallback = Context -> [XObj] -> IO (Context, Either EvalError XObj)
newtype CommandFunctionType = CommandFunction { getCommand :: CommandCallback }
instance Eq CommandFunctionType where
a == b = True
_ == _ = True
instance Show CommandFunctionType where
show t = "CommandFunction { ... }"
show _ = "CommandFunction { ... }"
newtype TemplateCreator = TemplateCreator { getTemplateCreator :: TypeEnv -> Env -> Template }
@ -266,7 +266,7 @@ getSimpleNameWithArgs xobj@(XObj (Lst (XObj Dynamic _ _ : _ : XObj (Arr args) _
Just $
"(" ++ getSimpleName xobj ++ (if not (null args) then " " else "") ++
unwords (map getSimpleName args) ++ ")"
getSimpleNameWithArgs xobj = Nothing
getSimpleNameWithArgs _ = Nothing
-- | Extracts the second form (where the name of definitions are stored) from a list of XObj:s.
getPath :: XObj -> SymPath
@ -318,7 +318,7 @@ pretty = visit 0
Str str -> show str
Pattern str -> '#' : show str
Chr c -> '\\' : c : ""
Sym path mode -> show path -- ++ " <" ++ show mode ++ ">"
Sym path _ -> show path -- ++ " <" ++ show mode ++ ">"
MultiSym originalName paths -> originalName ++ "{" ++ joinWithComma (map show paths) ++ "}"
InterfaceSym name -> name -- ++ "§"
Bol b -> if b then "true" else "false"
@ -368,44 +368,44 @@ prettyUpTo max xobj =
where end =
-- we match all of them explicitly to get errors if we forget one
case obj xobj of
Lst lst -> ")"
Arr arr -> "]"
Dict dict -> "}"
Num LongTy num -> "l"
Num IntTy num -> ""
Num ByteTy num -> "b"
Num FloatTy num -> show num ++ "f"
Num DoubleTy num -> ""
Lst _ -> ")"
Arr _ -> "]"
Dict _ -> "}"
Num LongTy _ -> "l"
Num IntTy _ -> ""
Num ByteTy _ -> "b"
Num FloatTy _ -> "f"
Num DoubleTy _ -> ""
Num _ _ -> error "Invalid number type."
Str str -> ""
Pattern str -> ""
Chr c -> ""
Sym path mode -> ""
MultiSym originalName paths -> "}"
InterfaceSym name -> ""
Bol b -> ""
Str _ -> ""
Pattern _ -> ""
Chr _ -> ""
Sym _ _ -> ""
MultiSym _ _ -> "}"
InterfaceSym _ -> ""
Bol _ -> ""
Defn maybeCaptures ->
case maybeCaptures of
Just captures -> ">"
Just _ -> ">"
Nothing -> ""
Def -> ""
Fn _ captures -> ">"
Closure elem _ -> ">"
Fn _ _ -> ">"
Closure _ _ -> ">"
If -> ""
Match _ -> ""
While -> ""
Do -> ""
Let -> ""
LetDef -> ""
Mod env -> ""
Mod _ -> ""
Deftype _ -> ""
DefSumtype _ -> ""
Deftemplate _ -> ""
Instantiate _ -> ""
External Nothing -> ""
External (Just override) -> ")"
External (Just _) -> ")"
ExternalType Nothing -> ""
ExternalType (Just override) -> ")"
ExternalType (Just _) -> ")"
MetaStub -> ""
Defalias _ -> ""
Address -> ""
@ -666,7 +666,7 @@ xobjToTy (XObj (Lst [XObj (Sym (SymPath _ "Fn") _) _ _, XObj (Arr argTys) _ _, r
xobjToTy (XObj (Lst [XObj (Sym (SymPath _ "Fn") _) _ _, XObj (Arr argTys) _ _, retTy, lifetime]) _ _) =
do okArgTys <- mapM xobjToTy argTys
okRetTy <- xobjToTy retTy
okLifetime <- xobjToTy lifetime
_ <- xobjToTy lifetime
pure (FuncTy okArgTys okRetTy StaticLifetimeTy)
xobjToTy (XObj (Lst []) _ _) = Just UnitTy
xobjToTy (XObj (Lst (x:xs)) _ _) =
@ -674,7 +674,7 @@ xobjToTy (XObj (Lst (x:xs)) _ _) =
okXS <- mapM xobjToTy xs
case okX of
(StructTy n []) -> pure (StructTy n okXS)
v@(VarTy n) -> pure (StructTy v okXS) -- Struct type with type variable as a name, i.e. "(a b)"
v@(VarTy _) -> pure (StructTy v okXS) -- Struct type with type variable as a name, i.e. "(a b)"
_ -> Nothing
xobjToTy _ = Nothing

12
src/Parsing.hs
View File

@ -48,7 +48,7 @@ otherBases = do i <- createInfo
where f :: Int -> Char -> Int
f x '0' = shift x 1
f x '1' = shift x 1 + 1
f x _ = error "Not a valid binary literal (this should not happen)."
f _ _ = error "Not a valid binary literal (this should not happen)."
withBases :: Parsec.Parsec String ParseState (Maybe Info, String)
withBases = Parsec.try otherBases <|> maybeSigned
@ -166,11 +166,11 @@ parseInternalPattern = do maybeAnchor <- Parsec.optionMaybe (Parsec.char '^')
_ -> pure ['\\', c]
capture :: Parsec.Parsec String ParseState String
capture = do
opening <- Parsec.char '('
_ <- Parsec.char '('
str <- Parsec.many (Parsec.try patternEscaped <|>
Parsec.try bracketClass <|>
simple)
closing <- Parsec.char ')'
_ <- Parsec.char ')'
pure $ "(" ++ concat str ++ ")"
range :: Parsec.Parsec String ParseState String
range = do
@ -180,12 +180,12 @@ parseInternalPattern = do maybeAnchor <- Parsec.optionMaybe (Parsec.char '^')
pure [begin, '-', end]
bracketClass :: Parsec.Parsec String ParseState String
bracketClass = do
opening <- Parsec.char '['
_ <- Parsec.char '['
maybeAnchor <- Parsec.optionMaybe (Parsec.char '^')
str <- Parsec.many (Parsec.try range <|>
Parsec.try patternEscaped <|>
Parsec.many1 (Parsec.noneOf "-^$()[]\\\""))
closing <- Parsec.char ']'
_ <- Parsec.char ']'
pure $ "[" ++ unwrapMaybe maybeAnchor ++ concat str ++ "]"
pat :: Parsec.Parsec String ParseState XObj
@ -504,7 +504,7 @@ balance text =
case parens of
[] -> push c
'"':xs -> case c of
'\\' -> do c <- Parsec.anyChar -- consume next
'\\' -> do _ <- Parsec.anyChar -- consume next
pure ()
'"' -> Parsec.putState xs -- close string
_ -> pure () -- inside string

2
src/Polymorphism.hs
View File

@ -13,7 +13,7 @@ import Lookup
-- | TODO: Environments are passed in different order here!!!
nameOfPolymorphicFunction :: TypeEnv -> Env -> Ty -> String -> Maybe SymPath
nameOfPolymorphicFunction typeEnv env functionType functionName =
nameOfPolymorphicFunction _ env functionType functionName =
let foundBinders = multiLookupALL functionName env
in case filter ((\(Just t') -> areUnifiable functionType t') . ty . binderXObj . snd) foundBinders of
[] -> Nothing

50
src/Primitives.hs
View File

@ -161,9 +161,9 @@ primitiveImplements xobj ctx [x@(XObj (Sym interface@(SymPath _ _) _) _ _), inne
newMeta = Meta.set "implements" impls meta
in (ctx' {contextGlobalEnv = envInsertAt global (getPath defobj) (Binder newMeta defobj)}, dynamicNil)
global = contextGlobalEnv ctx
primitiveImplements xobj ctx [x, y] =
primitiveImplements _ ctx [x, _] =
pure $ evalError ctx ("`implements` expects symbol arguments.") (info x)
primitiveImplements x@(XObj _ i t) ctx args =
primitiveImplements x@(XObj _ _ _) ctx args =
pure $ evalError
ctx ("`implements` expected 2 arguments, but got " ++ show (length args)) (info x)
@ -273,7 +273,7 @@ primitiveInfo _ ctx [target@(XObj (Sym path@(SymPath _ name) _) _ _)] = do
Nothing -> printer env True True (lookupInEnv path env)
found -> do _ <- printer env True True found -- this will print the interface itself
printer env True False (lookupInEnv path env)-- this will print the locations of the implementers of the interface
qualifiedPath ->
_ ->
case lookupInEnv path env of
Nothing -> notFound ctx target path
found -> printer env False True found
@ -292,7 +292,7 @@ primitiveInfo _ ctx [target@(XObj (Sym path@(SymPath _ name) _) _ _)] = do
pure (ctx, dynamicNil)
binders -> do liftIO $
mapM_
(\ (env, binder@(Binder metaData x@(XObj _ i _))) ->
(\ (_, binder@(Binder metaData x@(XObj _ i _))) ->
case i of
Just i' -> do
putStrLnWithColor White
@ -309,9 +309,9 @@ primitiveInfo _ ctx [target@(XObj (Sym path@(SymPath _ name) _) _ _)] = do
Just (XObj (Str val) _ _) -> liftIO $ putStrLn ("Documentation: " ++ val)
Nothing -> pure ()
case Meta.get "implements" metaData of
Just xobj@(XObj object info _) -> do
Just xobj@(XObj _ info _) -> do
case info of
Just info' -> putStrLn $ "Implementing: " ++ getName xobj
Just _ -> putStrLn $ "Implementing: " ++ getName xobj
Nothing -> pure ()
Nothing -> pure ()
liftIO $ when (projectPrintTypedAST proj) $ putStrLnWithColor Yellow (prettyTyped x)
@ -336,21 +336,21 @@ primitiveMembers _ ctx [target] = do
XObj (Sym path@(SymPath _ name) _) _ _ ->
case lookupInEnv path (getTypeEnv typeEnv) of
Just (_, Binder _ (XObj (Lst [
XObj (Deftype structTy) Nothing Nothing,
XObj (Sym (SymPath pathStrings typeName) Symbol) Nothing Nothing,
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 structTy) Nothing Nothing :
XObj (Sym (SymPath pathStrings typeName) Symbol) Nothing Nothing :
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 sym _) _ _) =
getMembersFromCase x@(XObj (Sym _ _) _ _) =
[XObj (Lst [x, XObj (Arr []) Nothing Nothing]) Nothing Nothing]
getMembersFromCase (XObj x _ _) =
error ("Can't handle case " ++ show x)
@ -372,7 +372,7 @@ primitiveMembers _ ctx [target] = do
-- | Set meta data for a Binder
primitiveMetaSet :: Primitive
primitiveMetaSet _ ctx [target@(XObj (Sym path@(SymPath prefixes name) _) _ _), XObj (Str key) _ _, value] =
primitiveMetaSet _ ctx [target@(XObj (Sym (SymPath prefixes name) _) _ _), XObj (Str key) _ _, value] =
pure $ maybe create (\newCtx -> (newCtx, dynamicNil)) lookupAndUpdate
where fullPath@(SymPath modules _) = consPath (union (contextPath ctx) prefixes) (SymPath [] name)
@ -382,11 +382,11 @@ primitiveMetaSet _ ctx [target@(XObj (Sym path@(SymPath prefixes name) _) _ _),
lookupAndUpdate :: Maybe Context
lookupAndUpdate = ((lookupInEnv dynamicPath global)
>>= \(e, binder) -> (pure (Meta.updateBinderMeta binder key value))
>>= \(_, binder) -> (pure (Meta.updateBinderMeta binder key value))
>>= \b -> (pure (envInsertAt global dynamicPath b))
>>= \env -> pure (ctx {contextGlobalEnv = env}))
<|> ((lookupInEnv fullPath global)
>>= \(e, binder) -> (pure (Meta.updateBinderMeta binder key value))
>>= \(_, binder) -> (pure (Meta.updateBinderMeta binder key value))
>>= \b -> (pure (envInsertAt global fullPath b))
>>= \env -> pure (ctx {contextGlobalEnv = env}))
-- This is a global name but it doesn't exist in the global env
@ -458,7 +458,7 @@ primitiveRegister _ ctx [name, _] =
(info name))
primitiveRegister _ ctx [XObj (Sym (SymPath _ name) _) _ _, ty, XObj (Str override) _ _] =
registerInternal ctx name ty (Just override)
primitiveRegister _ ctx [XObj (Sym (SymPath _ name) _) _ _, _, override] =
primitiveRegister _ ctx [XObj (Sym (SymPath _ _) _) _ _, _, override] =
pure (evalError ctx
("`register` expects a string as third argument, but got `" ++ pretty override ++ "`")
(info override))
@ -494,7 +494,7 @@ primitiveDeftype xobj ctx (name:rest) =
members (binding:val:xs) = do
xs' <- members xs
Just $ (binding, val) : xs'
members (x:[]) = Nothing
members (_:[]) = Nothing
members [] = Just []
ensureUnqualified :: [XObj] -> IO (Context, Either EvalError XObj)
@ -573,12 +573,12 @@ primitiveUse xobj ctx [XObj (Sym path _) _ _] =
lookupInGlobal = maybe missing useModule (lookupInEnv path env)
where missing = evalError ctx ("Can't find a module named '" ++ show path ++ "'") (info xobj)
useModule _ = (ctx { contextGlobalEnv = envReplaceEnvAt env pathStrings e' }, dynamicNil)
primitiveUse xobj ctx [x] =
primitiveUse _ ctx [x] =
argumentErr ctx "use" "a symbol" "first" x
-- | Get meta data for a Binder
primitiveMeta :: Primitive
primitiveMeta (XObj _ i _) ctx [XObj (Sym path@(SymPath prefixes name) _) _ _, XObj (Str key) _ _] = do
primitiveMeta (XObj _ i _) ctx [XObj (Sym (SymPath prefixes name) _) _ _, XObj (Str key) _ _] = do
pure $ maybe notFound foundBinder lookup
where global = contextGlobalEnv ctx
@ -597,7 +597,7 @@ primitiveMeta (XObj _ i _) ctx [XObj (Sym path@(SymPath prefixes name) _) _ _, X
notFound :: (Context, Either EvalError XObj)
notFound = evalError ctx ("`meta` failed, I can’t find `" ++ show fullPath ++ "`") i
primitiveMeta _ ctx [XObj (Sym path _) _ _, key] =
primitiveMeta _ ctx [XObj (Sym _ _) _ _, key] =
argumentErr ctx "meta" "a string" "second" key
primitiveMeta _ ctx [path, _] =
argumentErr ctx "meta" "a symbol" "first" path
@ -611,7 +611,7 @@ primitiveDefined _ ctx [arg] =
primitiveDeftemplate :: Primitive
-- deftemplate can't receive a dependency function, as Ty aren't exposed in Carp
primitiveDeftemplate _ ctx [XObj (Sym (SymPath [] name) _) pinfo _, ty, XObj (Str declTempl) _ _, XObj (Str defTempl) _ _] =
primitiveDeftemplate _ ctx [XObj (Sym (SymPath [] name) _) _ _, ty, XObj (Str declTempl) _ _, XObj (Str defTempl) _ _] =
pure $ maybe invalidType validType (xobjToTy ty)
where pathStrings = contextPath ctx
typeEnv = contextTypeEnv ctx
@ -646,9 +646,9 @@ noTypeError ctx x = pure $ evalError ctx ("Can't get the type of: " ++ pretty x)
primitiveType :: Primitive
-- A special case, the type of the type of types (type (type (type 1))) => ()
primitiveType _ ctx [x@(XObj _ _ (Just Universe))] =
primitiveType _ ctx [(XObj _ _ (Just Universe))] =
pure (ctx, Right (XObj (Lst []) Nothing Nothing))
primitiveType _ ctx [x@(XObj _ _ (Just TypeTy))] = liftIO $ pure (ctx, Right $ reify TypeTy)
primitiveType _ ctx [(XObj _ _ (Just TypeTy))] = liftIO $ pure (ctx, Right $ reify TypeTy)
primitiveType _ ctx [x@(XObj (Sym path@(SymPath [] name) _) _ _)] =
(maybe otherDefs (go ctx . snd) (lookupInEnv path env))
where env = contextGlobalEnv ctx
@ -680,7 +680,7 @@ primitiveType _ ctx [x@(XObj (Sym qualifiedPath _) _ _)] =
-- (type '(Pair.init 1 1)) => (Pair Int Int)
-- Contrarily the behavior is far more consistent as a primitive if we simply add this case, and from a user perspective, it makes more sense
-- that this function would be one that *doesn't* evaluate its arguments.
primitiveType any ctx [x@(XObj (Lst (XObj (Sym (SymPath [] "type") _) _ _: rest)) _ _)] =
primitiveType any ctx [(XObj (Lst (XObj (Sym (SymPath [] "type") _) _ _: rest)) _ _)] =
primitiveType any ctx rest
>>= \result -> case snd result of
Right xobj -> primitiveType any (fst result) [xobj]
@ -689,7 +689,7 @@ primitiveType _ ctx [x@(XObj _ _ _)] =
let tenv = contextTypeEnv ctx
typed = annotate tenv (contextGlobalEnv ctx) x Nothing
in liftIO $ either fail ok typed
where fail e = pure (evalError ctx ("Can't get the type of: " ++ pretty x) (info x))
where fail _ = pure (evalError ctx ("Can't get the type of: " ++ pretty x) (info x))
ok ((XObj _ _ (Just t)),_) = pure (ctx, Right $ reify t)
ok (_,_) = pure (evalError ctx ("Can't get the type of: " ++ pretty x) (info x))
@ -698,7 +698,7 @@ primitiveKind _ ctx [x@(XObj _ _ _)] =
let tenv = contextTypeEnv ctx
typed = annotate tenv (contextGlobalEnv ctx) x Nothing
in pure (either fail ok typed)
where fail e = (evalError ctx ("Can't get the kind of: " ++ pretty x) (info x))
where fail _ = (evalError ctx ("Can't get the kind of: " ++ pretty x) (info x))
ok (XObj _ _ (Just t), _) = (ctx, Right $ reify (tyToKind t))
ok (_, _) = (evalError ctx ("Can't get the kind of: " ++ pretty x) (info x))

10
src/Qualify.hs
View File

@ -74,7 +74,7 @@ setFullyQualifiedSymbols typeEnv globalEnv env (XObj (Lst (matchExpr@(XObj (Matc
newCasesXObjs =
map (\(l, r) ->
case l of
XObj (Lst (x:xs)) _ _ ->
XObj (Lst (_:xs)) _ _ ->
let l' = setFullyQualifiedSymbols typeEnv globalEnv env l
innerEnv' = foldl' folder innerEnv xs
where folder e v = case v of
@ -82,7 +82,7 @@ setFullyQualifiedSymbols typeEnv globalEnv env (XObj (Lst (matchExpr@(XObj (Matc
extendEnv e binderName v
-- Nested sumtypes
-- fold recursively -- is there a more efficient way?
XObj (Lst(y:ys)) _ _ ->
XObj (Lst(_:ys)) _ _ ->
foldl' folder innerEnv ys
x ->
error ("Can't match variable with " ++ show x)
@ -109,7 +109,7 @@ setFullyQualifiedSymbols typeEnv globalEnv localEnv xobj@(XObj (Sym path _) i t)
-- Unqualified:
SymPath [] name ->
case lookupInEnv path (getTypeEnv typeEnv) of
Just found@(_, Binder _ (XObj (Lst (XObj (Interface _ _) _ _ : _)) _ _)) ->
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
@ -192,11 +192,11 @@ setFullyQualifiedSymbols typeEnv globalEnv localEnv xobj@(XObj (Sym path _) i t)
bs
setFullyQualifiedSymbols typeEnv globalEnv env xobj@(XObj (Arr array) i t) =
setFullyQualifiedSymbols typeEnv globalEnv env (XObj (Arr array) i t) =
let array' = map (setFullyQualifiedSymbols typeEnv globalEnv env) array
in XObj (Arr array') i t
setFullyQualifiedSymbols typeEnv globalEnv env xobj@(XObj (StaticArr array) i t) =
setFullyQualifiedSymbols typeEnv globalEnv env (XObj (StaticArr array) i t) =
let array' = map (setFullyQualifiedSymbols typeEnv globalEnv env) array
in XObj (StaticArr array') i t

2
src/RenderDocs.hs
View File

@ -111,7 +111,7 @@ envBinderToHtml envBinder ctx moduleName moduleNames =
mapM_ (binderToHtml . snd) (Prelude.filter shouldEmitDocsForBinder (Map.toList (envBindings env)))
shouldEmitDocsForBinder :: (String, Binder) -> Bool
shouldEmitDocsForBinder (name, Binder meta xobj) =
shouldEmitDocsForBinder (_, Binder meta _) =
not (metaIsTrue meta "hidden")
moduleIndex :: [String] -> H.Html

2
src/Repl.hs
View File

@ -27,7 +27,7 @@ completeKeywordsAnd :: Context -> String -> [Completion]
completeKeywordsAnd context word =
findKeywords word (bindingNames (contextGlobalEnv context) ++ keywords) []
where
findKeywords match [] res = res
findKeywords _ [] res = res
findKeywords match (x : xs) res =
if match `isPrefixOf` x
then findKeywords match xs (res ++ [simpleCompletion x])

8
src/Scoring.hs
View File

@ -64,7 +64,7 @@ depthOfType typeEnv visited selfName theType =
else visitType theType + 1
where
visitType :: Ty -> Int
visitType t@(StructTy name varTys) = depthOfStructType (tyToC t) varTys
visitType t@(StructTy _ varTys) = depthOfStructType (tyToC t) varTys
visitType (FuncTy argTys retTy ltTy) =
-- trace ("Depth of args of " ++ show argTys ++ ": " ++ show (map (visitType . Just) argTys))
maximum (visitType ltTy : visitType retTy : fmap visitType argTys)
@ -95,11 +95,11 @@ depthOfType typeEnv visited selfName theType =
-- | The score is used for sorting the bindings before emitting them.
-- | A lower score means appearing earlier in the emitted file.
scoreValueBinder :: Env -> Set.Set SymPath -> Binder -> (Int, Binder)
scoreValueBinder globalEnv _ binder@(Binder _ (XObj (Lst (XObj (External _) _ _ : _)) _ _)) =
scoreValueBinder _ _ binder@(Binder _ (XObj (Lst (XObj (External _) _ _ : _)) _ _)) =
(0, binder)
scoreValueBinder globalEnv visited binder@(Binder _ (XObj (Lst [XObj Def _ _, XObj (Sym path Symbol) _ _, body]) _ _)) =
scoreValueBinder globalEnv visited binder@(Binder _ (XObj (Lst [XObj Def _ _, XObj (Sym _ Symbol) _ _, body]) _ _)) =
(scoreBody globalEnv visited body, binder)
scoreValueBinder globalEnv visited binder@(Binder _ (XObj (Lst [XObj (Defn _) _ _, XObj (Sym path Symbol) _ _, _, body]) _ _)) =
scoreValueBinder globalEnv visited binder@(Binder _ (XObj (Lst [XObj (Defn _) _ _, XObj (Sym _ Symbol) _ _, _, body]) _ _)) =
(scoreBody globalEnv visited body, binder)
scoreValueBinder _ _ binder =
(0, binder)

6
src/StaticArrayTemplates.hs
View File

@ -30,7 +30,7 @@ templateUnsafeNth =
," assert(n < a.len);"
," return &((($t*)a.data)[n]);"
,"}"])
(\(FuncTy [RefTy arrayType _, _] _ _) ->
(\(FuncTy [RefTy _ _, _] _ _) ->
[])
templateLength :: (String, Binder)
@ -61,7 +61,7 @@ templateDeleteArray = defineTypeParameterizedTemplate templateCreator path t doc
[TokDecl, TokC "{\n"] ++
deleteTy typeEnv env arrayType ++
[TokC "}\n"])
(\(FuncTy [arrayType@(StructTy concreteArray [insideType])] UnitTy _) ->
(\(FuncTy [(StructTy _ [insideType])] UnitTy _) ->
depsForDeleteFunc typeEnv env insideType)
deleteTy :: TypeEnv -> Env -> Ty -> [Token]
@ -105,7 +105,7 @@ templateStrArray = defineTypeParameterizedTemplate templateCreator path t docs
[TokDecl, TokC " {\n"] ++
ArrayTemplates.strTy typeEnv env arrayType ++
[TokC "}\n"])
(\(FuncTy [RefTy arrayType@(StructTy concreteArray [insideType]) _] StringTy _) ->
(\(FuncTy [RefTy (StructTy _ [insideType]) _] StringTy _) ->
depsForPrnFunc typeEnv env insideType)
path = SymPath ["StaticArray"] "str"
t = FuncTy [RefTy (StructTy concreteArray [VarTy "a"]) (VarTy "q")] StringTy StaticLifetimeTy

34
src/Sumtypes.hs
View File

@ -55,7 +55,7 @@ initers :: [String] -> Ty -> [SumtypeCase] -> Either TypeError [(String, Binder)
initers insidePath structTy cases = mapM (binderForCaseInit insidePath structTy) cases
binderForCaseInit :: [String] -> Ty -> SumtypeCase -> Either TypeError (String, Binder)
binderForCaseInit insidePath structTy@(StructTy (ConcreteNameTy typeName) _) sumtypeCase =
binderForCaseInit insidePath structTy@(StructTy (ConcreteNameTy _) _) sumtypeCase =
if isTypeGeneric structTy
then Right (genericCaseInit StackAlloc insidePath structTy sumtypeCase)
else Right (concreteCaseInit StackAlloc insidePath structTy sumtypeCase)
@ -81,7 +81,7 @@ genericCaseInit allocationMode pathStrings originalStructTy sumtypeCase =
t = FuncTy (caseTys sumtypeCase) originalStructTy StaticLifetimeTy
docs = "creates a `" ++ caseName sumtypeCase ++ "`."
templateCreator = TemplateCreator $
\typeEnv env ->
\typeEnv _ ->
Template
(FuncTy (caseTys sumtypeCase) (VarTy "p") StaticLifetimeTy)
(\(FuncTy _ concreteStructTy _) ->
@ -98,7 +98,7 @@ genericCaseInit allocationMode pathStrings originalStructTy sumtypeCase =
Right ok -> ok)
tokensForCaseInit :: AllocationMode -> Ty -> SumtypeCase -> [Token]
tokensForCaseInit allocationMode sumTy@(StructTy (ConcreteNameTy typeName) typeVariables) sumtypeCase =
tokensForCaseInit allocationMode sumTy@(StructTy (ConcreteNameTy typeName) _) sumtypeCase =
toTemplate $ unlines [ "$DECL {"
, case allocationMode of
StackAlloc -> " $p instance;"
@ -132,7 +132,7 @@ binderForTag insidePath originalStructTy@(StructTy (ConcreteNameTy typeName) _)
-- | Helper function to create the binder for the 'str' template.
binderForStrOrPrn :: TypeEnv -> Env -> [String] -> Ty -> [SumtypeCase] -> String -> Either TypeError ((String, Binder), [XObj])
binderForStrOrPrn typeEnv env insidePath structTy@(StructTy (ConcreteNameTy typeName) _) cases strOrPrn =
binderForStrOrPrn typeEnv env insidePath structTy@(StructTy (ConcreteNameTy _) _) cases strOrPrn =
Right $ if isTypeGeneric structTy
then (genericStr insidePath structTy cases strOrPrn, [])
else concreteStr typeEnv env insidePath structTy cases strOrPrn
@ -146,16 +146,16 @@ concreteStr typeEnv env insidePath concreteStructTy@(StructTy (ConcreteNameTy ty
Template
(FuncTy [RefTy concreteStructTy (VarTy "q")] StringTy StaticLifetimeTy)
(\(FuncTy [RefTy structTy _] StringTy _) -> toTemplate $ "String $NAME(" ++ tyToCLambdaFix structTy ++ " *p)")
(\(FuncTy [RefTy structTy@(StructTy _ concreteMemberTys) _] StringTy _) ->
(\(FuncTy [RefTy (StructTy _ _) _] StringTy _) ->
tokensForStr typeEnv env typeName cases concreteStructTy)
(\ft@(FuncTy [RefTy structTy@(StructTy _ concreteMemberTys) _] StringTy _) ->
(\(FuncTy [RefTy (StructTy _ _) _] StringTy _) ->
concatMap (depsOfPolymorphicFunction typeEnv env [] "prn" . typesStrFunctionType typeEnv)
(filter (\t -> (not . isExternalType typeEnv) t && (not . isFullyGenericType) t) (concatMap caseTys cases))
)
-- | The template for the 'str' function for a generic deftype.
genericStr :: [String] -> Ty -> [SumtypeCase] -> String -> (String, Binder)
genericStr insidePath originalStructTy@(StructTy (ConcreteNameTy typeName) varTys) cases strOrPrn =
genericStr insidePath originalStructTy@(StructTy (ConcreteNameTy typeName) _) cases strOrPrn =
defineTypeParameterizedTemplate templateCreator path t docs
where path = SymPath insidePath strOrPrn
t = FuncTy [RefTy originalStructTy (VarTy "q")] StringTy StaticLifetimeTy
@ -166,11 +166,11 @@ genericStr insidePath originalStructTy@(StructTy (ConcreteNameTy typeName) varTy
t
(\(FuncTy [RefTy concreteStructTy _] StringTy _) ->
toTemplate $ "String $NAME(" ++ tyToCLambdaFix concreteStructTy ++ " *p)")
(\(FuncTy [RefTy concreteStructTy@(StructTy _ concreteMemberTys) _] StringTy _) ->
(\(FuncTy [RefTy concreteStructTy@(StructTy _ _) _] StringTy _) ->
let mappings = unifySignatures originalStructTy concreteStructTy
correctedCases = replaceGenericTypesOnCases mappings cases
in tokensForStr typeEnv env typeName correctedCases concreteStructTy)
(\ft@(FuncTy [RefTy concreteStructTy@(StructTy _ concreteMemberTys) _] StringTy _) ->
(\ft@(FuncTy [RefTy concreteStructTy@(StructTy _ _) _] StringTy _) ->
let mappings = unifySignatures originalStructTy concreteStructTy
correctedCases = replaceGenericTypesOnCases mappings cases
tys = filter (\t -> (not . isExternalType typeEnv) t && (not . isFullyGenericType) t) (concatMap caseTys correctedCases)
@ -179,7 +179,7 @@ genericStr insidePath originalStructTy@(StructTy (ConcreteNameTy typeName) varTy
(if isTypeGeneric concreteStructTy then [] else [defineFunctionTypeAlias ft]))
tokensForStr :: TypeEnv -> Env -> String -> [SumtypeCase] -> Ty -> [Token]
tokensForStr typeEnv env typeName cases concreteStructTy =
tokensForStr typeEnv env _ cases concreteStructTy =
toTemplate $ unlines [ "$DECL {"
, " // convert members to String here:"
, " String temp = NULL;"
@ -199,7 +199,7 @@ namesFromCase theCase concreteStructTy =
in (name, caseTys theCase {caseTys = (remove isUnit (caseTys theCase))}, tagName concreteStructTy name)
strCase :: TypeEnv -> Env -> Ty -> SumtypeCase -> String
strCase typeEnv env concreteStructTy@(StructTy _ typeVariables) theCase =
strCase typeEnv env concreteStructTy@(StructTy _ _) theCase =
let (name, tys, correctedTagName) = namesFromCase theCase concreteStructTy
in unlines
[ " if(p->_tag == " ++ correctedTagName ++ ") {"
@ -213,12 +213,12 @@ strCase typeEnv env concreteStructTy@(StructTy _ typeVariables) theCase =
-- | Figure out how big the string needed for the string representation of the struct has to be.
calculateStructStrSize :: TypeEnv -> Env -> [SumtypeCase] -> Ty -> String
calculateStructStrSize typeEnv env cases structTy@(StructTy (ConcreteNameTy name) _) =
calculateStructStrSize typeEnv env cases structTy@(StructTy (ConcreteNameTy _) _) =
" int size = 1;\n" ++
concatMap (strSizeCase typeEnv env structTy) cases
strSizeCase :: TypeEnv -> Env -> Ty -> SumtypeCase -> String
strSizeCase typeEnv env concreteStructTy@(StructTy _ typeVariables) theCase =
strSizeCase typeEnv env concreteStructTy@(StructTy _ _) theCase =
let (name, tys, correctedTagName) = namesFromCase theCase concreteStructTy
in unlines
[ " if(p->_tag == " ++ correctedTagName ++ ") {"
@ -229,7 +229,7 @@ strSizeCase typeEnv env concreteStructTy@(StructTy _ typeVariables) theCase =
-- | Helper function to create the binder for the 'delete' template.
binderForDelete :: TypeEnv -> Env -> [String] -> Ty -> [SumtypeCase] -> Either TypeError (String, Binder)
binderForDelete typeEnv env insidePath structTy@(StructTy (ConcreteNameTy typeName) _) cases =
binderForDelete typeEnv env insidePath structTy@(StructTy (ConcreteNameTy _) _) cases =
Right $ if isTypeGeneric structTy
then genericSumtypeDelete insidePath structTy cases
else concreteSumtypeDelete insidePath typeEnv env structTy cases
@ -275,7 +275,7 @@ concreteSumtypeDelete insidePath typeEnv env structTy@(StructTy (ConcreteNameTy
(filter (isManaged typeEnv) (concatMap caseTys cases)))
deleteCase :: TypeEnv -> Env -> Ty -> (SumtypeCase, Bool) -> String
deleteCase typeEnv env concreteStructTy@(StructTy _ typeVariables) (theCase, isFirstCase) =
deleteCase typeEnv env concreteStructTy@(StructTy _ _) (theCase, isFirstCase) =
let (name, tys, correctedTagName) = namesFromCase theCase concreteStructTy
in unlines
[ " " ++ (if isFirstCase then "" else "else ") ++ "if(p._tag == " ++ correctedTagName ++ ") {"
@ -285,7 +285,7 @@ deleteCase typeEnv env concreteStructTy@(StructTy _ typeVariables) (theCase, isF
-- | Helper function to create the binder for the 'copy' template.
binderForCopy :: TypeEnv -> Env -> [String] -> Ty -> [SumtypeCase] -> Either TypeError ((String, Binder), [XObj])
binderForCopy typeEnv env insidePath structTy@(StructTy (ConcreteNameTy typeName) _) cases =
binderForCopy typeEnv env insidePath structTy@(StructTy (ConcreteNameTy _) _) cases =
Right $ if isTypeGeneric structTy
then (genericSumtypeCopy insidePath structTy cases, [])
else concreteSumtypeCopy insidePath typeEnv env structTy cases
@ -335,7 +335,7 @@ tokensForSumtypeCopy typeEnv env concreteStructTy cases =
, "}"]
copyCase :: TypeEnv -> Env -> Ty -> (SumtypeCase, Bool) -> String
copyCase typeEnv env concreteStructTy@(StructTy _ typeVariables) (theCase, isFirstCase) =
copyCase typeEnv env concreteStructTy@(StructTy _ _) (theCase, isFirstCase) =
let (name, tys, correctedTagName) = namesFromCase theCase concreteStructTy
in unlines
[ " " ++ (if isFirstCase then "" else "else ") ++ "if(pRef->_tag == " ++ correctedTagName ++ ") {"

16
src/TypeError.hs
View File

@ -113,7 +113,7 @@ instance Show TypeError where
"There are no expressions in the body body of the form at " ++
prettyInfoFromXObj xobj ++
".\n\nI need exactly one body form. For multiple forms, try using `do`."
show (UnificationFailed constraint@(Constraint a b aObj bObj ctx _) mappings constraints) =
show (UnificationFailed (Constraint a b aObj bObj ctx _) mappings _) =
"I can’t match the types `" ++ show (recursiveLookupTy mappings a) ++
"` and `" ++ show (recursiveLookupTy mappings b) ++ "`" ++ extra ++
".\n\n" ++
@ -185,10 +185,10 @@ instance Show TypeError where
show (ArraysCannotContainRefs xobj) =
"Arrays can’t contain references: `" ++ pretty xobj ++ "` at " ++
prettyInfoFromXObj xobj ++ ".\n\nYou’ll have to make a copy using `@`."
show (MainCanOnlyReturnUnitOrInt xobj t) =
show (MainCanOnlyReturnUnitOrInt _ t) =
"The main function can only return an `Int` or a unit type (`()`), but it got `" ++
show t ++ "`."
show (MainCannotHaveArguments xobj c) =
show (MainCannotHaveArguments _ c) =
"The main function may not receive arguments, but it got " ++ show c ++ "."
show (CannotConcretize xobj) =
"I’m unable to concretize the expression '" ++ pretty xobj ++ "' at " ++
@ -204,7 +204,7 @@ instance Show TypeError where
show (CannotSet xobj) =
"I can’t `set!` the expression `" ++ pretty xobj ++ "` at " ++
prettyInfoFromXObj xobj ++ ".\n\nOnly variables can be reset using `set!`."
show (CannotSetVariableFromLambda variable xobj) =
show (CannotSetVariableFromLambda variable _) =
"I can’t `set!` the variable `" ++ pretty variable ++ "` at " ++
prettyInfoFromXObj variable ++ " because it's defined outside the lambda."
show (DoesNotMatchSignatureAnnotation xobj sigTy) =
@ -249,7 +249,7 @@ instance Show TypeError where
machineReadableErrorStrings :: FilePathPrintLength -> TypeError -> [String]
machineReadableErrorStrings fppl err =
case err of
(UnificationFailed constraint@(Constraint a b aObj bObj _ _) mappings constraints) ->
(UnificationFailed (Constraint a b aObj bObj _ _) mappings _) ->
[machineReadableInfoFromXObj fppl aObj ++ " Inferred " ++ showTypeFromXObj mappings aObj ++ ", can't unify with " ++ show (recursiveLookupTy mappings b) ++ "."
,machineReadableInfoFromXObj fppl bObj ++ " Inferred " ++ showTypeFromXObj mappings bObj ++ ", can't unify with " ++ show (recursiveLookupTy mappings a) ++ "."]
@ -261,7 +261,7 @@ machineReadableErrorStrings fppl err =
[machineReadableInfoFromXObj fppl xobj ++ " Expression '" ++ pretty xobj ++ "' missing type."]
(SymbolNotDefined symPath xobj _) ->
[machineReadableInfoFromXObj fppl xobj ++ " Trying to refer to an undefined symbol '" ++ show symPath ++ "'."]
(SymbolMissingType xobj env) ->
(SymbolMissingType xobj _) ->
[machineReadableInfoFromXObj fppl xobj ++ " Symbol '" ++ getName xobj ++ "' missing type."]
(InvalidObj (Defn _) xobj) ->
[machineReadableInfoFromXObj fppl xobj ++ " Invalid function definition."]
@ -336,7 +336,7 @@ machineReadableErrorStrings fppl err =
(CannotSet xobj) ->
[machineReadableInfoFromXObj fppl xobj ++ " Can't set! '" ++ pretty xobj ++ "'."]
(CannotSetVariableFromLambda variable xobj) ->
(CannotSetVariableFromLambda variable _) ->
[machineReadableInfoFromXObj fppl variable ++ " Can't set! '" ++ pretty variable ++ "' from inside of a lambda."]
(CannotConcretize xobj) ->
@ -363,7 +363,7 @@ machineReadableErrorStrings fppl err =
[machineReadableInfoFromXObj fppl xobj ++ " Duplicate binding `" ++ pretty xobj ++ "` inside `let`."]
(DefinitionsMustBeAtToplevel xobj) ->
[machineReadableInfoFromXObj fppl xobj ++ " Definition not at top level: `" ++ pretty xobj ++ "`"]
(UsingDeadReference xobj dependsOn) ->
(UsingDeadReference xobj _) ->
[machineReadableInfoFromXObj fppl xobj ++ " The reference '" ++ pretty xobj ++ "' isn't alive."]
(UninhabitedConstructor ty xobj got wanted) ->
[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]

14
src/Types.hs
View File

@ -160,7 +160,7 @@ replaceConflicted name (StructTy n tyArgs) = StructTy (replaceConflicted name n)
replaceConflicted name (PointerTy p) = PointerTy (replaceConflicted name p)
replaceConflicted name (RefTy r lt) = RefTy (replaceConflicted name r)
(replaceConflicted name lt)
replaceConflicted name t = t
replaceConflicted _ t = t
-- | Map type variable names to actual types, eg. t0 => Int, t1 => Float
@ -171,28 +171,28 @@ type TypeMappings = Map.Map String Ty
unifySignatures :: Ty -> Ty -> TypeMappings
unifySignatures v t = Map.fromList (unify v t)
where unify :: Ty -> Ty -> [(String, Ty)]
unify a@(VarTy _) b@(VarTy _) = [] -- if a == b then [] else error ("Can't unify " ++ show a ++ " with " ++ show b)
unify (VarTy _) (VarTy _) = [] -- if a == b then [] else error ("Can't unify " ++ show a ++ " with " ++ show b)
unify (VarTy a) value = [(a, value)]
unify (StructTy v@(VarTy a) aArgs) (StructTy n bArgs) = unify v n ++ concat (zipWith unify aArgs bArgs)
unify (StructTy v@(VarTy _) aArgs) (StructTy n bArgs) = unify v n ++ concat (zipWith unify aArgs bArgs)
unify (StructTy a@(ConcreteNameTy _) aArgs) (StructTy b bArgs)
| a == b = concat (zipWith unify aArgs bArgs)
| otherwise = [] -- error ("Can't unify " ++ a ++ " with " ++ b)
unify a@(StructTy _ _) b = [] -- error ("Can't unify " ++ show a ++ " with " ++ show b)
unify (StructTy _ _) _ = [] -- error ("Can't unify " ++ show a ++ " with " ++ show b)
unify (PointerTy a) (PointerTy b) = unify a b
unify a@(PointerTy _) b = [] -- error ("Can't unify " ++ show a ++ " with " ++ show b)
unify (PointerTy _) _ = [] -- error ("Can't unify " ++ show a ++ " with " ++ show b)
unify (RefTy a ltA) (RefTy b ltB) = unify a b ++ unify ltA ltB
unify a@(RefTy _ _) b = [] -- error ("Can't unify " ++ show a ++ " with " ++ show b)
unify (RefTy _ _) _ = [] -- error ("Can't unify " ++ show a ++ " with " ++ show b)
unify (FuncTy argTysA retTyA ltA) (FuncTy argTysB retTyB ltB) =
let argToks = concat (zipWith unify argTysA argTysB)
retToks = unify retTyA retTyB
ltToks = unify ltA ltB
in ltToks ++ argToks ++ retToks
unify a@FuncTy{} b = [] -- error ("Can't unify " ++ show a ++ " with " ++ show b)
unify FuncTy{} _ = [] -- error ("Can't unify " ++ show a ++ " with " ++ show b)
unify a b | a == b = []
| otherwise = [] -- error ("Can't unify " ++ show a ++ " with " ++ show b)

4
src/TypesToC.hs
View File

@ -10,14 +10,14 @@ tyToC :: Ty -> String
tyToC = tyToCManglePtr False
tyToCLambdaFix :: Ty -> String
tyToCLambdaFix t@FuncTy{} = "Lambda"
tyToCLambdaFix FuncTy{} = "Lambda"
tyToCLambdaFix (RefTy FuncTy{} _) = "Lambda*"
tyToCLambdaFix (RefTy (RefTy FuncTy{} _) _) = "Lambda**"
tyToCLambdaFix (RefTy (RefTy (RefTy FuncTy{} _) _) _) = "Lambda***" -- | TODO: More cases needed?! What's a better way to do it..?
tyToCLambdaFix t = tyToCManglePtr False t
tyToCRawFunctionPtrFix :: Ty -> String
tyToCRawFunctionPtrFix t@FuncTy{} = "void*"
tyToCRawFunctionPtrFix FuncTy{} = "void*"
tyToCRawFunctionPtrFix t = tyToCManglePtr False t
tyToCManglePtr :: Bool -> Ty -> String

8
src/Validate.hs
View File

@ -63,16 +63,16 @@ canBeUsedAsMemberType typeEnv typeVariables t xobj =
Just _ -> pure ()
Nothing -> Left (NotAmongRegisteredTypes t xobj)
-- e.g. (deftype (Higher (f a)) (Of [(f a)]))
t@(VarTy _) -> pure ()
(VarTy _) -> pure ()
s@(StructTy name tyvar) ->
if isExternalType typeEnv s
then pure ()
else case name of
(ConcreteNameTy n) ->
case lookupInEnv (SymPath [] n) (getTypeEnv typeEnv) of
Just (_, binder@(Binder _ xo@(XObj (Lst (XObj (Deftype t') _ _ : _))_ _))) ->
Just (_, (Binder _ (XObj (Lst (XObj (Deftype t') _ _ : _))_ _))) ->
checkInhabitants t'
Just (_, binder@(Binder _ xo@(XObj (Lst (XObj (DefSumtype t') _ _ : _))_ _))) ->
Just (_, (Binder _ (XObj (Lst (XObj (DefSumtype t') _ _ : _))_ _))) ->
checkInhabitants t'
_ -> Left (InvalidMemberType t xobj)
-- Make sure any struct types have arguments before they can be used as members.
@ -91,5 +91,5 @@ canBeUsedAsMemberType typeEnv typeVariables t xobj =
-- If a variable `a` appears in a higher-order polymorphic form, such as `(f a)`
-- `a` may be used as a member, sans `f`.
isCaptured t v@(VarTy _) = t == v
isCaptured t (StructTy (VarTy v) vars) = any (== t) vars
isCaptured t (StructTy (VarTy _) vars) = any (== t) vars
_ -> Left (InvalidMemberType t xobj)