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

refactor: Apply Ormolu auto-formatting (#1045)

Browse Source
This commit is contained in:
Erik Svedäng 2020-12-02 16:33:37 +01:00 committed by GitHub
parent f89a3f130e
commit 7920a751bf
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
45 changed files with 9490 additions and 7780 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
Setup.hs
View File

@ -1,2 +1,3 @@
import Distribution.Simple
main = defaultMain

349
app/Main.hs
View File

@ -1,195 +1,208 @@
module Main where
import qualified System.Environment as SystemEnvironment
import System.Console.Haskeline (runInputT)
import System.Exit (exitFailure)
import Control.Monad (foldM, when)
import GHC.IO.Encoding
import Data.Maybe
import ColorText
import Control.Monad (foldM, when)
import Data.Maybe
import Eval
import GHC.IO.Encoding
import Info
import Obj
import Options.Applicative
import Path
import Project
import Types
import Repl
import StartingEnv
import Eval
import System.Console.Haskeline (runInputT)
import qualified System.Environment as SystemEnvironment
import System.Exit (exitFailure)
import Types
import Util
import Path
import Info
import Options.Applicative
defaultProject :: Project
defaultProject =
Project { projectTitle = "Untitled"
, projectIncludes = []
, projectCFlags =
case platform of
Windows ->
[ "-D_CRT_SECURE_NO_WARNINGS"
]
_ ->
[ "-fPIC"
, "-g"
, "-std=c99"
-- , "-pedantic"
, "-D_DEFAULT_SOURCE"
, "-Wall"
, "-Werror"
, "-Wno-unused-variable"
, "-Wno-self-assign"
]
, projectLibFlags = case platform of
Windows -> []
_ -> [ "-lm" ]
, projectFiles = []
, projectAlreadyLoaded = []
, projectEchoC = False
, projectLibDir = "libs"
, projectCarpDir = "."
, projectOutDir = "out"
, projectDocsDir = "docs"
, projectDocsLogo = ""
, projectDocsPrelude = ""
, projectDocsURL = ""
, projectDocsGenerateIndex = True
, projectDocsStyling = "carp_style.css"
, projectBalanceHints = True
, projectPrompt = case platform of
MacOS -> "鲤 "
_ -> "> "
, projectCarpSearchPaths = []
, projectPrintTypedAST = False
, projectCompiler = case platform of
Windows -> "clang-cl.exe"
_ -> "clang"
, projectTarget = Native
, projectCore = True
, projectEchoCompilationCommand = False
, projectCanExecute = False
, projectFilePathPrintLength = FullPath
, projectGenerateOnly = False
, projectForceReload = False
, projectPkgConfigFlags = []
, projectCModules = []
, projectLoadStack = []
}
Project
{ projectTitle = "Untitled",
projectIncludes = [],
projectCFlags = case platform of
Windows ->
[ "-D_CRT_SECURE_NO_WARNINGS"
]
_ ->
[ "-fPIC",
"-g",
"-std=c99",
-- , "-pedantic"
"-D_DEFAULT_SOURCE",
"-Wall",
"-Werror",
"-Wno-unused-variable",
"-Wno-self-assign"
],
projectLibFlags = case platform of
Windows -> []
_ -> ["-lm"],
projectFiles = [],
projectAlreadyLoaded = [],
projectEchoC = False,
projectLibDir = "libs",
projectCarpDir = ".",
projectOutDir = "out",
projectDocsDir = "docs",
projectDocsLogo = "",
projectDocsPrelude = "",
projectDocsURL = "",
projectDocsGenerateIndex = True,
projectDocsStyling = "carp_style.css",
projectBalanceHints = True,
projectPrompt = case platform of
MacOS -> "鲤 "
_ -> "> ",
projectCarpSearchPaths = [],
projectPrintTypedAST = False,
projectCompiler = case platform of
Windows -> "clang-cl.exe"
_ -> "clang",
projectTarget = Native,
projectCore = True,
projectEchoCompilationCommand = False,
projectCanExecute = False,
projectFilePathPrintLength = FullPath,
projectGenerateOnly = False,
projectForceReload = False,
projectPkgConfigFlags = [],
projectCModules = [],
projectLoadStack = []
}
-- | Starting point of the application.
main :: IO ()
main = do setLocaleEncoding utf8
args <- SystemEnvironment.getArgs
sysEnv <- SystemEnvironment.getEnvironment
fullOpts <- execParser $ Options.Applicative.info (parseFull <**> helper) fullDesc
let execMode = optExecMode fullOpts
otherOptions = optOthers fullOpts
argFilesToLoad = optFiles fullOpts
logMemory = otherLogMemory otherOptions
core = not $ otherNoCore otherOptions
profile = not $ otherNoProfile otherOptions
optimize = otherOptimize otherOptions
generateOnly = otherGenerateOnly otherOptions
prompt = otherPrompt otherOptions
carpDir = lookup "CARP_DIR" sysEnv
ifCarpDirSet comp =
case carpDir of
Just _ -> comp
Nothing -> do
emitWarning "The environment variable `CARP_DIR` is not set."
if core
then emitErrorAndExit "Cannot use core libraries without `CARP_DIR` being set (if you want to provide your own, use `--no-core`)."
else comp
applySettings p = p { projectCFlags = ["-D LOG_MEMORY" | logMemory] ++
["-O3 -D NDEBUG" | optimize]
++ projectCFlags p
, projectCore = core
, projectGenerateOnly = generateOnly
, projectCarpDir = fromMaybe (projectCarpDir p) carpDir
, projectPrompt = fromMaybe (projectPrompt p) prompt
}
project = applySettings defaultProject
noArray = False
startingContext = Context
(startingGlobalEnv noArray)
Nothing
(TypeEnv startingTypeEnv)
[]
project
""
execMode
[]
coreModulesToLoad = if core then coreModules (projectCarpDir project) else []
execStr :: String -> String -> Context -> IO Context
execStr info str ctx = executeString True False ctx str info
execStrs :: String -> [String] -> Context -> IO Context
execStrs info strs ctx = foldM (\ctx str -> execStr info str ctx) ctx strs
preloads = optPreload fullOpts
postloads = optPostload fullOpts
load = flip loadFiles
loadOnce = flip loadFilesOnce
carpProfile <- configPath "profile.carp"
hasProfile <- doesFileExist carpProfile
_ <- ifCarpDirSet
(pure startingContext
>>= load [carpProfile | hasProfile]
>>= execStrs "Preload" preloads
>>= loadOnce coreModulesToLoad
>>= load argFilesToLoad
>>= execStrs "Postload" postloads
>>= \ctx -> case execMode of
Repl -> do putStrLn "Welcome to Carp 0.4.2"
putStrLn "This is free software with ABSOLUTELY NO WARRANTY."
putStrLn "Evaluate (help) for more information."
snd <$> runRepl ctx
Build -> execStr "Compiler (Build)" "(build)" ctx
Install thing -> execStr "Installation" ("(load \"" ++ thing ++ "\")") ctx
BuildAndRun -> execStr "Compiler (Build & Run)" "(do (build) (run))" ctx
Check -> execStr "Check" "" ctx)
-- TODO: Handle the return value from executeString and return that one to the shell
pure ()
main = do
setLocaleEncoding utf8
args <- SystemEnvironment.getArgs
sysEnv <- SystemEnvironment.getEnvironment
fullOpts <- execParser $ Options.Applicative.info (parseFull <**> helper) fullDesc
let execMode = optExecMode fullOpts
otherOptions = optOthers fullOpts
argFilesToLoad = optFiles fullOpts
logMemory = otherLogMemory otherOptions
core = not $ otherNoCore otherOptions
profile = not $ otherNoProfile otherOptions
optimize = otherOptimize otherOptions
generateOnly = otherGenerateOnly otherOptions
prompt = otherPrompt otherOptions
carpDir = lookup "CARP_DIR" sysEnv
ifCarpDirSet comp =
case carpDir of
Just _ -> comp
Nothing -> do
emitWarning "The environment variable `CARP_DIR` is not set."
if core
then emitErrorAndExit "Cannot use core libraries without `CARP_DIR` being set (if you want to provide your own, use `--no-core`)."
else comp
applySettings p =
p
{ projectCFlags =
["-D LOG_MEMORY" | logMemory]
++ ["-O3 -D NDEBUG" | optimize]
++ projectCFlags p,
projectCore = core,
projectGenerateOnly = generateOnly,
projectCarpDir = fromMaybe (projectCarpDir p) carpDir,
projectPrompt = fromMaybe (projectPrompt p) prompt
}
project = applySettings defaultProject
noArray = False
startingContext =
Context
(startingGlobalEnv noArray)
Nothing
(TypeEnv startingTypeEnv)
[]
project
""
execMode
[]
coreModulesToLoad = if core then coreModules (projectCarpDir project) else []
execStr :: String -> String -> Context -> IO Context
execStr info str ctx = executeString True False ctx str info
execStrs :: String -> [String] -> Context -> IO Context
execStrs info strs ctx = foldM (\ctx str -> execStr info str ctx) ctx strs
preloads = optPreload fullOpts
postloads = optPostload fullOpts
load = flip loadFiles
loadOnce = flip loadFilesOnce
carpProfile <- configPath "profile.carp"
hasProfile <- doesFileExist carpProfile
_ <-
ifCarpDirSet
( pure startingContext
>>= load [carpProfile | hasProfile]
>>= execStrs "Preload" preloads
>>= loadOnce coreModulesToLoad
>>= load argFilesToLoad
>>= execStrs "Postload" postloads
>>= \ctx -> case execMode of
Repl -> do
putStrLn "Welcome to Carp 0.4.2"
putStrLn "This is free software with ABSOLUTELY NO WARRANTY."
putStrLn "Evaluate (help) for more information."
snd <$> runRepl ctx
Build -> execStr "Compiler (Build)" "(build)" ctx
Install thing -> execStr "Installation" ("(load \"" ++ thing ++ "\")") ctx
BuildAndRun -> execStr "Compiler (Build & Run)" "(do (build) (run))" ctx
Check -> execStr "Check" "" ctx
)
-- TODO: Handle the return value from executeString and return that one to the shell
pure ()
-- | Options for how to run the compiler.
data FullOptions = FullOptions
{ optExecMode :: ExecutionMode
, optOthers :: OtherOptions
, optPreload :: [String]
, optPostload :: [String]
, optFiles :: [FilePath]
} deriving Show
data FullOptions
= FullOptions
{ optExecMode :: ExecutionMode,
optOthers :: OtherOptions,
optPreload :: [String],
optPostload :: [String],
optFiles :: [FilePath]
}
deriving (Show)
parseFull :: Parser FullOptions
parseFull = FullOptions
<$> parseExecMode
<*> parseOther
<*> many (strOption (long "eval-preload" <> metavar "CODE" <> help "Eval CODE after loading config and before FILES"))
<*> many (strOption (long "eval-postload" <> metavar "CODE" <> help "Eval CODE after loading FILES"))
<*> parseFiles
parseFull =
FullOptions
<$> parseExecMode
<*> parseOther
<*> many (strOption (long "eval-preload" <> metavar "CODE" <> help "Eval CODE after loading config and before FILES"))
<*> many (strOption (long "eval-postload" <> metavar "CODE" <> help "Eval CODE after loading FILES"))
<*> parseFiles
data OtherOptions = OtherOptions
{ otherNoCore :: Bool
, otherNoProfile :: Bool
, otherLogMemory :: Bool
, otherOptimize :: Bool
, otherGenerateOnly :: Bool
, otherPrompt :: Maybe String
} deriving Show
data OtherOptions
= OtherOptions
{ otherNoCore :: Bool,
otherNoProfile :: Bool,
otherLogMemory :: Bool,
otherOptimize :: Bool,
otherGenerateOnly :: Bool,
otherPrompt :: Maybe String
}
deriving (Show)
parseOther :: Parser OtherOptions
parseOther = OtherOptions
<$> switch (long "no-core" <> help "Don't load Core.carp")
<*> switch (long "no-profile" <> help "Don't load profile.carp")
<*> switch (long "log-memory" <> help "Log memory allocations")
<*> switch (long "optimize" <> help "Optimized build")
<*> switch (long "generate-only" <> help "Stop after generating the C code")
<*> optional (strOption (long "prompt" <> help "Set REPL prompt"))
parseOther =
OtherOptions
<$> switch (long "no-core" <> help "Don't load Core.carp")
<*> switch (long "no-profile" <> help "Don't load profile.carp")
<*> switch (long "log-memory" <> help "Log memory allocations")
<*> switch (long "optimize" <> help "Optimized build")
<*> switch (long "generate-only" <> help "Stop after generating the C code")
<*> optional (strOption (long "prompt" <> help "Set REPL prompt"))
parseExecMode :: Parser ExecutionMode
parseExecMode =
flag' Check (long "check" <> help "Check project")
<|> flag' Build (short 'b' <> help "Build project")
<|> flag' BuildAndRun (short 'x' <> help "Build an run project")
<|> Install <$> strOption (short 'i' <> help "Install built product")
<|> pure Repl
<|> flag' Build (short 'b' <> help "Build project")
<|> flag' BuildAndRun (short 'x' <> help "Build an run project")
<|> Install <$> strOption (short 'i' <> help "Install built product")
<|> pure Repl
parseFiles :: Parser [FilePath]
parseFiles = many (argument str (metavar "FILES..."))

318
headerparse/Main.hs
View File

@ -3,35 +3,51 @@
module Main where
import Options.Applicative hiding ((<|>))
import Text.Parsec ((<|>))
import qualified Text.Parsec as Parsec
import Data.Char (toLower, isUpper)
import Util
import Types
import Data.Char (isUpper, toLower)
import Obj
import Options.Applicative hiding ((<|>))
import Path
import Reify
import Text.Parsec ((<|>))
import qualified Text.Parsec as Parsec
import Types
import Util
data Args = Args { prefixToRemove :: String
, kebabCase :: Bool
, sourcePath :: String
} deriving Show
data Args
= Args
{ prefixToRemove :: String,
kebabCase :: Bool,
sourcePath :: String
}
deriving (Show)
parseArgs :: Parser Args
parseArgs = Args
<$> strOption (long "prefixtoremove" <> short 'p' <> metavar "ITEM" <> value "")
<*> switch (long "kebabcase" <> short 'f')
<*> argument str (metavar "FILE")
parseArgs =
Args
<$> strOption (long "prefixtoremove" <> short 'p' <> metavar "ITEM" <> value "")
<*> switch (long "kebabcase" <> short 'f')
<*> argument str (metavar "FILE")
main = do parsedArgs <- execParser $ Options.Applicative.info (parseArgs <**> helper) fullDesc
let path = sourcePath parsedArgs
if path /= ""
then do source <- slurp path
putStrLn (joinWith "\n" (map pretty (parseHeaderFile path source
(prefixToRemove parsedArgs)
(kebabCase parsedArgs))))
else print parsedArgs
main = do
parsedArgs <- execParser $ Options.Applicative.info (parseArgs <**> helper) fullDesc
let path = sourcePath parsedArgs
if path /= ""
then do
source <- slurp path
putStrLn
( joinWith
"\n"
( map
pretty
( parseHeaderFile
path
source
(prefixToRemove parsedArgs)
(kebabCase parsedArgs)
)
)
)
else print parsedArgs
parseHeaderFile :: FilePath -> String -> String -> Bool -> [XObj]
parseHeaderFile path src prefix kebab =
@ -39,130 +55,148 @@ parseHeaderFile path src prefix kebab =
Left err -> error (show err)
Right ok -> concat ok
where
cSyntax :: Parsec.Parsec String () [[XObj]]
cSyntax = Parsec.sepBy line (Parsec.char '\n')
cSyntax :: Parsec.Parsec String () [[XObj]]
cSyntax = Parsec.sepBy line (Parsec.char '\n')
line :: Parsec.Parsec String () [XObj]
line =
Parsec.try prefixedFunctionPrototype
<|> Parsec.try functionPrototype
<|> Parsec.try define
<|> discarded
define :: Parsec.Parsec String () [XObj]
define = do
Parsec.many spaceOrTab
Parsec.string "#define"
Parsec.many spaceOrTab
name <- Parsec.many1 identifierChar
argList <- Parsec.optionMaybe argList
Parsec.many spaceOrTab
_ <- defineBody
Parsec.many spaceOrTab
-- OBS! Never kebab
case argList of
Nothing ->
let tyXObj =
XObj (Sym (SymPath [] "a") Symbol) Nothing Nothing
in pure (createRegisterForm name tyXObj prefix False)
Just args ->
let argsTy = genTypes (length args)
tyXObj = toFnTypeXObj argsTy ("a", 0)
in pure (createRegisterForm name tyXObj prefix False)
where
argList = do
_ <- Parsec.char '('
args <-
Parsec.sepBy
( Parsec.many spaceOrTab
>> Parsec.many1 identifierChar
)
(Parsec.char ',')
_ <- Parsec.char ')'
pure args
genTypes 0 = []
genTypes n = (("a" ++ show n), 0) : genTypes (n - 1)
defineBody :: Parsec.Parsec String () ()
defineBody = do
s <- Parsec.many (Parsec.noneOf "\\\n")
ending <- Parsec.optionMaybe (Parsec.string "\\\n")
case ending of
Nothing ->
do
c <- Parsec.optionMaybe (Parsec.noneOf "\n")
case c of
Just _ -> defineBody
Nothing -> pure ()
Just _ -> defineBody
prefixedFunctionPrototype :: Parsec.Parsec String () [XObj]
prefixedFunctionPrototype = do
Parsec.many spaceOrTab
_ <- Parsec.many1 identifierChar
functionPrototype
functionPrototype :: Parsec.Parsec String () [XObj]
functionPrototype = do
Parsec.many spaceOrTab
returnTypeString <- Parsec.many1 identifierChar
stars1 <- stars
Parsec.many1 spaceOrTab
stars2 <- stars
name <- Parsec.many1 identifierChar
Parsec.many spaceOrTab
argTypeStrings <-
Parsec.try voidArg
<|> argList
Parsec.many spaceOrTab
Parsec.char ';'
Parsec.many (Parsec.noneOf "\n")
let tyXObj = toFnTypeXObj argTypeStrings (returnTypeString, length stars1 + length stars2)
pure (createRegisterForm name tyXObj prefix kebab)
voidArg :: Parsec.Parsec String () [(String, Int)]
voidArg = do
_ <- Parsec.string "(void)"
pure []
argList :: Parsec.Parsec String () [(String, Int)]
argList = do
Parsec.char '('
args <- Parsec.sepBy arg (Parsec.char ',')
Parsec.char ')'
pure args
arg :: Parsec.Parsec String () (String, Int)
arg = do
Parsec.many spaceOrTab
_ <- Parsec.option "" $ do
Parsec.string "const"
Parsec.many spaceOrTab
argTypeAsString <- Parsec.many1 identifierChar
stars1 <- stars
Parsec.many1 spaceOrTab
stars2 <- stars
_ <- Parsec.many1 identifierChar
Parsec.many spaceOrTab
pure (argTypeAsString, length stars1 + length stars2)
stars :: Parsec.Parsec String () String
stars = Parsec.many (Parsec.char '*')
spaceOrTab :: Parsec.Parsec String () Char
spaceOrTab = Parsec.choice [Parsec.char ' ', Parsec.char '\t']
discarded :: Parsec.Parsec String () [XObj]
discarded = do
discardedLine <- Parsec.many (Parsec.noneOf "\n")
pure []
line :: Parsec.Parsec String () [XObj]
line = Parsec.try prefixedFunctionPrototype <|>
Parsec.try functionPrototype <|>
Parsec.try define <|>
discarded
define :: Parsec.Parsec String () [XObj]
define = do Parsec.many spaceOrTab
Parsec.string "#define"
Parsec.many spaceOrTab
name <- Parsec.many1 identifierChar
argList <- Parsec.optionMaybe argList
Parsec.many spaceOrTab
_ <- defineBody
Parsec.many spaceOrTab
-- OBS! Never kebab
case argList of
Nothing ->
let tyXObj =
XObj (Sym (SymPath [] "a") Symbol) Nothing Nothing
in pure (createRegisterForm name tyXObj prefix False)
Just args ->
let argsTy = genTypes (length args)
tyXObj = toFnTypeXObj argsTy ("a", 0)
in pure (createRegisterForm name tyXObj prefix False)
where argList = do
_ <- Parsec.char '('
args <- Parsec.sepBy
(Parsec.many spaceOrTab >>
Parsec.many1 identifierChar)
(Parsec.char ',')
_ <- Parsec.char ')'
pure args
genTypes 0 = []
genTypes n = (("a" ++ show n), 0) : genTypes (n - 1)
defineBody :: Parsec.Parsec String () ()
defineBody = do s <- Parsec.many (Parsec.noneOf "\\\n")
ending <- Parsec.optionMaybe (Parsec.string "\\\n")
case ending of
Nothing ->
do c <- Parsec.optionMaybe (Parsec.noneOf "\n")
case c of
Just _ -> defineBody
Nothing -> pure ()
Just _ -> defineBody
prefixedFunctionPrototype :: Parsec.Parsec String () [XObj]
prefixedFunctionPrototype = do Parsec.many spaceOrTab
_ <- Parsec.many1 identifierChar
functionPrototype
functionPrototype :: Parsec.Parsec String () [XObj]
functionPrototype = do Parsec.many spaceOrTab
returnTypeString <- Parsec.many1 identifierChar
stars1 <- stars
Parsec.many1 spaceOrTab
stars2 <- stars
name <- Parsec.many1 identifierChar
Parsec.many spaceOrTab
argTypeStrings <- Parsec.try voidArg <|>
argList
Parsec.many spaceOrTab
Parsec.char ';'
Parsec.many (Parsec.noneOf "\n")
let tyXObj = toFnTypeXObj argTypeStrings (returnTypeString, length stars1 + length stars2)
pure (createRegisterForm name tyXObj prefix kebab)
voidArg :: Parsec.Parsec String () [(String, Int)]
voidArg = do _ <- Parsec.string "(void)"
pure []
argList :: Parsec.Parsec String () [(String, Int)]
argList = do Parsec.char '('
args <- Parsec.sepBy arg (Parsec.char ',')
Parsec.char ')'
pure args
arg :: Parsec.Parsec String () (String, Int)
arg = do Parsec.many spaceOrTab
_ <- Parsec.option "" $ do Parsec.string "const"
Parsec.many spaceOrTab
argTypeAsString <- Parsec.many1 identifierChar
stars1 <- stars
Parsec.many1 spaceOrTab
stars2 <- stars
_ <- Parsec.many1 identifierChar
Parsec.many spaceOrTab
pure (argTypeAsString, length stars1 + length stars2)
stars :: Parsec.Parsec String () String
stars = Parsec.many (Parsec.char '*')
spaceOrTab :: Parsec.Parsec String () Char
spaceOrTab = Parsec.choice [Parsec.char ' ', Parsec.char '\t']
discarded :: Parsec.Parsec String () [XObj]
discarded = do discardedLine <- Parsec.many (Parsec.noneOf "\n")
pure []
--pure [(XObj (Str ("DISCARDED: " ++ discardedLine)) Nothing Nothing)]
--pure [(XObj (Str ("DISCARDED: " ++ discardedLine)) Nothing Nothing)]
createRegisterForm :: String -> XObj -> String -> Bool -> [XObj]
createRegisterForm name tyXObj prefix kebab =
let carpName = (if kebab then (toKebab . lowerFirst) else id)
(if prefix == "" then name else removePrefix prefix name)
let carpName =
(if kebab then (toKebab . lowerFirst) else id)
(if prefix == "" then name else removePrefix prefix name)
emitName = name
in [XObj (Lst ([ (XObj (Sym (SymPath [] "register") Symbol) Nothing Nothing)
, (XObj (Sym (SymPath [] carpName) Symbol) Nothing Nothing)
, tyXObj
] ++
if prefix == ""
then []
else [(XObj (Str emitName) Nothing Nothing)]
)) Nothing Nothing]
in [ XObj
( Lst
( [ (XObj (Sym (SymPath [] "register") Symbol) Nothing Nothing),
(XObj (Sym (SymPath [] carpName) Symbol) Nothing Nothing),
tyXObj
]
++ if prefix == ""
then []
else [(XObj (Str emitName) Nothing Nothing)]
)
)
Nothing
Nothing
]
toFnTypeXObj :: [(String, Int)] -> (String, Int) -> XObj
toFnTypeXObj argTypeStrings returnTypeString =
(XObj (Lst [ (XObj (Sym (SymPath [] "λ") Symbol) Nothing Nothing)
, (XObj (Arr (map (reify . cTypeToCarpType) argTypeStrings)) Nothing Nothing)
, (XObj (Sym (SymPath [] (show (cTypeToCarpType returnTypeString))) Symbol) Nothing Nothing)
]) Nothing Nothing)
( XObj
( Lst
[ (XObj (Sym (SymPath [] "λ") Symbol) Nothing Nothing),
(XObj (Arr (map (reify . cTypeToCarpType) argTypeStrings)) Nothing Nothing),
(XObj (Sym (SymPath [] (show (cTypeToCarpType returnTypeString))) Symbol) Nothing Nothing)
]
)
Nothing
Nothing
)
toTypeXObj :: (String, Int) -> XObj
toTypeXObj typeString =
@ -187,9 +221,11 @@ removePrefix prefix s =
case Parsec.runParser match () "" s of
Left err -> s
Right ok -> ok
where match =
do _ <- Parsec.string prefix
Parsec.many1 identifierChar
where
match =
do
_ <- Parsec.string prefix
Parsec.many1 identifierChar
lowerFirst :: String -> String
lowerFirst (c : cs) = toLower c : cs

766
src/ArrayTemplates.hs
View File

@ -2,13 +2,13 @@
module ArrayTemplates where
import Types
import TypesToC
import Concretize
import Lookup
import Obj
import Template
import ToTemplate
import Concretize
import Lookup
import Types
import TypesToC
-- | "Endofunctor Map"
templateEMap :: (String, Binder)
@ -17,29 +17,33 @@ templateEMap =
aTy = StructTy (ConcreteNameTy "Array") [VarTy "a"]
bTy = StructTy (ConcreteNameTy "Array") [VarTy "a"]
elt = "((($a*)a.data)[i])"
in defineTemplate
(SymPath ["Array"] "endo-map")
(FuncTy [RefTy fTy (VarTy "q"), aTy] bTy StaticLifetimeTy)
"applies a function `f` to an array `a`. The type of the elements cannot change."
(toTemplate "Array $NAME(Lambda *f, Array a)") -- Lambda used to be $(Fn [a] a)
(toTemplate $ unlines
["$DECL { "
," for(int i = 0; i < a.len; ++i) {"
," (($a*)a.data)[i] = " ++ templateCodeForCallingLambda "(*f)" fTy [elt] ++ ";"
," }"
," return a;"
,"}"
])
(\(FuncTy [RefTy t@(FuncTy fArgTys fRetTy _) _, _] _ _) ->
[defineFunctionTypeAlias t, defineFunctionTypeAlias (FuncTy (lambdaEnvTy : fArgTys) fRetTy StaticLifetimeTy)])
in defineTemplate
(SymPath ["Array"] "endo-map")
(FuncTy [RefTy fTy (VarTy "q"), aTy] bTy StaticLifetimeTy)
"applies a function `f` to an array `a`. The type of the elements cannot change."
(toTemplate "Array $NAME(Lambda *f, Array a)") -- Lambda used to be $(Fn [a] a)
( toTemplate $
unlines
[ "$DECL { ",
" for(int i = 0; i < a.len; ++i) {",
" (($a*)a.data)[i] = " ++ templateCodeForCallingLambda "(*f)" fTy [elt] ++ ";",
" }",
" return a;",
"}"
]
)
( \(FuncTy [RefTy t@(FuncTy fArgTys fRetTy _) _, _] _ _) ->
[defineFunctionTypeAlias t, defineFunctionTypeAlias (FuncTy (lambdaEnvTy : fArgTys) fRetTy StaticLifetimeTy)]
)
templateShrinkCheck :: String -> String
templateShrinkCheck var =
unlines [ " if(" ++ var ++ ".len < (" ++ var ++ ".capacity / 4)) {"
," " ++ var ++ ".capacity = " ++ var ++ ".len * 2;"
," " ++ var ++ ".data = CARP_REALLOC(" ++ var ++ ".data, sizeof($a) * " ++ var ++ " .capacity);"
, " }"
]
unlines
[ " if(" ++ var ++ ".len < (" ++ var ++ ".capacity / 4)) {",
" " ++ var ++ ".capacity = " ++ var ++ ".len * 2;",
" " ++ var ++ ".data = CARP_REALLOC(" ++ var ++ ".data, sizeof($a) * " ++ var ++ " .capacity);",
" }"
]
-- | Endofunctor filter, misnomer for consistency with flavors of map
templateEFilter :: (String, Binder)
@ -54,293 +58,348 @@ templateEFilter = defineTypeParameterizedTemplate templateCreator path t docs
templateCreator = TemplateCreator $
\typeEnv env ->
Template
t
(const (toTemplate "Array $NAME(Lambda *predicate, Array a)")) -- Lambda used to be $(Fn [(Ref a)] Bool)
(\(FuncTy [RefTy (FuncTy [RefTy insideTy _] BoolTy _) _, _] _ _) ->
toTemplate $ unlines $
let deleter = insideArrayDeletion typeEnv env insideTy
in ["$DECL { "
, " int insertIndex = 0;"
, " for(int i = 0; i < a.len; ++i) {"
, " if(" ++ templateCodeForCallingLambda "(*predicate)" fTy [elt] ++ ") {"
, " ((($a*)a.data)[insertIndex++]) = (($a*)a.data)[i];"
, " } else {"
, " " ++ deleter "i"
, " }"
, " }"
, " a.len = insertIndex;"
, templateShrinkCheck "a"
, " return a;"
, "}"
])
(\(FuncTy [RefTy ft@(FuncTy fArgTys@[RefTy insideType _] BoolTy _) _, _] _ _) ->
[defineFunctionTypeAlias ft, defineFunctionTypeAlias (FuncTy (lambdaEnvTy : fArgTys) BoolTy StaticLifetimeTy)] ++
depsForDeleteFunc typeEnv env insideType)
t
(const (toTemplate "Array $NAME(Lambda *predicate, Array a)")) -- Lambda used to be $(Fn [(Ref a)] Bool)
( \(FuncTy [RefTy (FuncTy [RefTy insideTy _] BoolTy _) _, _] _ _) ->
toTemplate $ unlines $
let deleter = insideArrayDeletion typeEnv env insideTy
in [ "$DECL { ",
" int insertIndex = 0;",
" for(int i = 0; i < a.len; ++i) {",
" if(" ++ templateCodeForCallingLambda "(*predicate)" fTy [elt] ++ ") {",
" ((($a*)a.data)[insertIndex++]) = (($a*)a.data)[i];",
" } else {",
" " ++ deleter "i",
" }",
" }",
" a.len = insertIndex;",
templateShrinkCheck "a",
" return a;",
"}"
]
)
( \(FuncTy [RefTy ft@(FuncTy fArgTys@[RefTy insideType _] BoolTy _) _, _] _ _) ->
[defineFunctionTypeAlias ft, defineFunctionTypeAlias (FuncTy (lambdaEnvTy : fArgTys) BoolTy StaticLifetimeTy)]
++ depsForDeleteFunc typeEnv env insideType
)
templatePushBack :: (String, Binder)
templatePushBack =
let aTy = StructTy (ConcreteNameTy "Array") [VarTy "a"]
valTy = VarTy "a"
in defineTemplate
(SymPath ["Array"] "push-back")
(FuncTy [aTy, valTy] aTy StaticLifetimeTy)
"adds an element `value` to the end of an array `a`."
(toTemplate "Array $NAME(Array a, $a value)")
(toTemplate $ unlines
["$DECL { "
," a.len++;"
," if(a.len > a.capacity) {"
," a.capacity = a.len * 2;"
," a.data = CARP_REALLOC(a.data, sizeof($a) * a.capacity);"
," }"
," (($a*)a.data)[a.len - 1] = value;"
," return a;"
,"}"
])
(\(FuncTy [_, _] _ _) -> [])
in defineTemplate
(SymPath ["Array"] "push-back")
(FuncTy [aTy, valTy] aTy StaticLifetimeTy)
"adds an element `value` to the end of an array `a`."
(toTemplate "Array $NAME(Array a, $a value)")
( toTemplate $
unlines
[ "$DECL { ",
" a.len++;",
" if(a.len > a.capacity) {",
" a.capacity = a.len * 2;",
" a.data = CARP_REALLOC(a.data, sizeof($a) * a.capacity);",
" }",
" (($a*)a.data)[a.len - 1] = value;",
" return a;",
"}"
]
)
(\(FuncTy [_, _] _ _) -> [])
templatePushBackBang :: (String, Binder)
templatePushBackBang =
let aTy = RefTy (StructTy (ConcreteNameTy "Array") [VarTy "a"]) (VarTy "q")
valTy = VarTy "a"
in defineTemplate
(SymPath ["Array"] "push-back!")
(FuncTy [aTy, valTy] UnitTy StaticLifetimeTy)
"adds an element `value` to the end of an array `a` in-place."
(toTemplate "void $NAME(Array *aRef, $a value)")
(toTemplate $ unlines
["$DECL { "
," aRef->len++;"
," if(aRef->len > aRef->capacity) {"
," aRef->capacity = aRef->len * 2;"
," aRef->data = CARP_REALLOC(aRef->data, sizeof($a) * aRef->capacity);"
," }"
," (($a*)aRef->data)[aRef->len - 1] = value;"
,"}"
])
(\(FuncTy [_, _] _ _) -> [])
in defineTemplate
(SymPath ["Array"] "push-back!")
(FuncTy [aTy, valTy] UnitTy StaticLifetimeTy)
"adds an element `value` to the end of an array `a` in-place."
(toTemplate "void $NAME(Array *aRef, $a value)")
( toTemplate $
unlines
[ "$DECL { ",
" aRef->len++;",
" if(aRef->len > aRef->capacity) {",
" aRef->capacity = aRef->len * 2;",
" aRef->data = CARP_REALLOC(aRef->data, sizeof($a) * aRef->capacity);",
" }",
" (($a*)aRef->data)[aRef->len - 1] = value;",
"}"
]
)
(\(FuncTy [_, _] _ _) -> [])
templatePopBack :: (String, Binder)
templatePopBack = defineTypeParameterizedTemplate templateCreator path t docs
where path = SymPath ["Array"] "pop-back"
aTy = StructTy (ConcreteNameTy "Array") [VarTy "a"]
t = FuncTy [aTy] aTy StaticLifetimeTy
docs = "removes the last element of an array and returns the new array."
templateCreator = TemplateCreator $
\typeEnv env ->
Template
t
(const (toTemplate "Array $NAME(Array a)"))
(\(FuncTy [(StructTy _ [insideTy])] _ _) ->
let deleteElement = insideArrayDeletion typeEnv env insideTy
in toTemplate (unlines
["$DECL { "
," assert(a.len > 0);"
," a.len--;"
," " ++ deleteElement "a.len"
, templateShrinkCheck "a"
," return a;"
,"}"
]))
(\(FuncTy [arrayType@(StructTy _ [insideTy])] _ _) ->
depsForDeleteFunc typeEnv env arrayType ++
depsForCopyFunc typeEnv env insideTy
)
where
path = SymPath ["Array"] "pop-back"
aTy = StructTy (ConcreteNameTy "Array") [VarTy "a"]
t = FuncTy [aTy] aTy StaticLifetimeTy
docs = "removes the last element of an array and returns the new array."
templateCreator = TemplateCreator $
\typeEnv env ->
Template
t
(const (toTemplate "Array $NAME(Array a)"))
( \(FuncTy [(StructTy _ [insideTy])] _ _) ->
let deleteElement = insideArrayDeletion typeEnv env insideTy
in toTemplate
( unlines
[ "$DECL { ",
" assert(a.len > 0);",
" a.len--;",
" " ++ deleteElement "a.len",
templateShrinkCheck "a",
" return a;",
"}"
]
)
)
( \(FuncTy [arrayType@(StructTy _ [insideTy])] _ _) ->
depsForDeleteFunc typeEnv env arrayType
++ depsForCopyFunc typeEnv env insideTy
)
templatePopBackBang :: (String, Binder)
templatePopBackBang =
let aTy = RefTy (StructTy (ConcreteNameTy "Array") [VarTy "a"]) (VarTy "q")
in defineTemplate
(SymPath ["Array"] "pop-back!")
(FuncTy [aTy] (VarTy "a") StaticLifetimeTy)
"removes an element `value` from the end of an array `a` in-place and returns it."
(toTemplate "$a $NAME(Array *aRef)")
(toTemplate $ unlines
["$DECL { "
," $a ret;"
," assert(aRef->len > 0);"
," ret = (($a*)aRef->data)[aRef->len - 1];"
," aRef->len--;"
," return ret;"
,"}"
])
(\(FuncTy [_] _ _) -> [])
in defineTemplate
(SymPath ["Array"] "pop-back!")
(FuncTy [aTy] (VarTy "a") StaticLifetimeTy)
"removes an element `value` from the end of an array `a` in-place and returns it."
(toTemplate "$a $NAME(Array *aRef)")
( toTemplate $
unlines
[ "$DECL { ",
" $a ret;",
" assert(aRef->len > 0);",
" ret = (($a*)aRef->data)[aRef->len - 1];",
" aRef->len--;",
" return ret;",
"}"
]
)
(\(FuncTy [_] _ _) -> [])
templateNth :: (String, Binder)
templateNth =
let t = VarTy "t"
in defineTemplate
(SymPath ["Array"] "unsafe-nth")
(FuncTy [RefTy (StructTy (ConcreteNameTy "Array") [t]) (VarTy "q"), IntTy] (RefTy t (VarTy "q")) StaticLifetimeTy)
"gets a reference to the `n`th element from an array `a`."
(toTemplate "$t* $NAME (Array *aRef, int n)")
(toTemplate $ unlines ["$DECL {"
," Array a = *aRef;"
," assert(n >= 0);"
," assert(n < a.len);"
," return &((($t*)a.data)[n]);"
,"}"])
(\(FuncTy [RefTy _ _, _] _ _) ->
[])
in defineTemplate
(SymPath ["Array"] "unsafe-nth")
(FuncTy [RefTy (StructTy (ConcreteNameTy "Array") [t]) (VarTy "q"), IntTy] (RefTy t (VarTy "q")) StaticLifetimeTy)
"gets a reference to the `n`th element from an array `a`."
(toTemplate "$t* $NAME (Array *aRef, int n)")
( toTemplate $
unlines
[ "$DECL {",
" Array a = *aRef;",
" assert(n >= 0);",
" assert(n < a.len);",
" return &((($t*)a.data)[n]);",
"}"
]
)
( \(FuncTy [RefTy _ _, _] _ _) ->
[]
)
templateRaw :: (String, Binder)
templateRaw = defineTemplate
(SymPath ["Array"] "raw")
(FuncTy [StructTy (ConcreteNameTy "Array") [VarTy "t"]] (PointerTy (VarTy "t")) StaticLifetimeTy)
"returns an array `a` as a raw pointer—useful for interacting with C."
(toTemplate "$t* $NAME (Array a)")
(toTemplate "$DECL { return a.data; }")
(\(FuncTy [_] _ _) -> [])
templateRaw =
defineTemplate
(SymPath ["Array"] "raw")
(FuncTy [StructTy (ConcreteNameTy "Array") [VarTy "t"]] (PointerTy (VarTy "t")) StaticLifetimeTy)
"returns an array `a` as a raw pointer—useful for interacting with C."
(toTemplate "$t* $NAME (Array a)")
(toTemplate "$DECL { return a.data; }")
(\(FuncTy [_] _ _) -> [])
templateUnsafeRaw :: (String, Binder)
templateUnsafeRaw = defineTemplate
(SymPath ["Array"] "unsafe-raw")
(FuncTy [RefTy (VarTy "q") (StructTy (ConcreteNameTy "Array") [VarTy "t"])] (PointerTy (VarTy "t")) StaticLifetimeTy)
"returns an array `a` as a raw pointer—useful for interacting with C."
(toTemplate "$t* $NAME (Array* a)")
(toTemplate "$DECL { return a->data; }")
(\(FuncTy [RefTy _ _] _ _) -> [])
templateUnsafeRaw =
defineTemplate
(SymPath ["Array"] "unsafe-raw")
(FuncTy [RefTy (VarTy "q") (StructTy (ConcreteNameTy "Array") [VarTy "t"])] (PointerTy (VarTy "t")) StaticLifetimeTy)
"returns an array `a` as a raw pointer—useful for interacting with C."
(toTemplate "$t* $NAME (Array* a)")
(toTemplate "$DECL { return a->data; }")
(\(FuncTy [RefTy _ _] _ _) -> [])
templateAset :: (String, Binder)
templateAset = defineTypeParameterizedTemplate templateCreator path t docs
where path = SymPath ["Array"] "aset"
t = FuncTy [StructTy (ConcreteNameTy "Array") [VarTy "t"], IntTy, VarTy "t"] (StructTy (ConcreteNameTy "Array") [VarTy "t"]) StaticLifetimeTy
docs = "sets an array element at the index `n` to a new value."
templateCreator = TemplateCreator $
\typeEnv env ->
Template
t
(\_ -> toTemplate "Array $NAME (Array a, int n, $t newValue)")
(\(FuncTy [_, _, insideTy] _ _) ->
let deleter = insideArrayDeletion typeEnv env insideTy
in toTemplate $ unlines ["$DECL {"
," assert(n >= 0);"
," assert(n < a.len);"
, deleter "n"
," (($t*)a.data)[n] = newValue;"
," return a;"
,"}"])
(\(FuncTy [_, _, insideTy] _ _) ->
depsForDeleteFunc typeEnv env insideTy)
where
path = SymPath ["Array"] "aset"
t = FuncTy [StructTy (ConcreteNameTy "Array") [VarTy "t"], IntTy, VarTy "t"] (StructTy (ConcreteNameTy "Array") [VarTy "t"]) StaticLifetimeTy
docs = "sets an array element at the index `n` to a new value."
templateCreator = TemplateCreator $
\typeEnv env ->
Template
t
(\_ -> toTemplate "Array $NAME (Array a, int n, $t newValue)")
( \(FuncTy [_, _, insideTy] _ _) ->
let deleter = insideArrayDeletion typeEnv env insideTy
in toTemplate $
unlines
[ "$DECL {",
" assert(n >= 0);",
" assert(n < a.len);",
deleter "n",
" (($t*)a.data)[n] = newValue;",
" return a;",
"}"
]
)
( \(FuncTy [_, _, insideTy] _ _) ->
depsForDeleteFunc typeEnv env insideTy
)
templateAsetBang :: (String, Binder)
templateAsetBang = defineTypeParameterizedTemplate templateCreator path t docs
where path = SymPath ["Array"] "aset!"
t = FuncTy [RefTy (StructTy (ConcreteNameTy "Array") [VarTy "t"]) (VarTy "q"), IntTy, VarTy "t"] UnitTy StaticLifetimeTy
docs = "sets an array element at the index `n` to a new value in place."
templateCreator = TemplateCreator $
\typeEnv env ->
Template
t
(const (toTemplate "void $NAME (Array *aRef, int n, $t newValue)"))
(\(FuncTy [_, _, insideTy] _ _) ->
let deleter = insideArrayDeletion typeEnv env insideTy
in (toTemplate $ unlines ["$DECL {"
," Array a = *aRef;"
," assert(n >= 0);"
," assert(n < a.len);"
, deleter "n"
," (($t*)a.data)[n] = newValue;"
,"}"]))
(\(FuncTy [RefTy arrayType _, _, _] _ _) ->
depsForDeleteFunc typeEnv env arrayType)
where
path = SymPath ["Array"] "aset!"
t = FuncTy [RefTy (StructTy (ConcreteNameTy "Array") [VarTy "t"]) (VarTy "q"), IntTy, VarTy "t"] UnitTy StaticLifetimeTy
docs = "sets an array element at the index `n` to a new value in place."
templateCreator = TemplateCreator $
\typeEnv env ->
Template
t
(const (toTemplate "void $NAME (Array *aRef, int n, $t newValue)"))
( \(FuncTy [_, _, insideTy] _ _) ->
let deleter = insideArrayDeletion typeEnv env insideTy
in ( toTemplate $
unlines
[ "$DECL {",
" Array a = *aRef;",
" assert(n >= 0);",
" assert(n < a.len);",
deleter "n",
" (($t*)a.data)[n] = newValue;",
"}"
]
)
)
( \(FuncTy [RefTy arrayType _, _, _] _ _) ->
depsForDeleteFunc typeEnv env arrayType
)
-- | This function can set uninitialized memory in an array (used together with 'allocate').
-- | It will NOT try to free the value that is already at location 'n'.
templateAsetUninitializedBang :: (String, Binder)
templateAsetUninitializedBang = defineTypeParameterizedTemplate templateCreator path t docs
where path = SymPath ["Array"] "aset-uninitialized!"
t = FuncTy [RefTy (StructTy (ConcreteNameTy "Array") [VarTy "t"]) (VarTy "q"), IntTy, VarTy "t"] UnitTy StaticLifetimeTy
docs = "sets an uninitialized array member. The old member will not be deleted."
templateCreator = TemplateCreator $
\_ _ ->
Template
t
(const (toTemplate "void $NAME (Array *aRef, int n, $t newValue)"))
(const (toTemplate $ unlines ["$DECL {"
," Array a = *aRef;"
," assert(n >= 0);"
," assert(n < a.len);"
," (($t*)a.data)[n] = newValue;"
,"}"]))
(const [])
where
path = SymPath ["Array"] "aset-uninitialized!"
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 $
\_ _ ->
Template
t
(const (toTemplate "void $NAME (Array *aRef, int n, $t newValue)"))
( const
( toTemplate $
unlines
[ "$DECL {",
" Array a = *aRef;",
" assert(n >= 0);",
" assert(n < a.len);",
" (($t*)a.data)[n] = newValue;",
"}"
]
)
)
(const [])
templateLength :: (String, Binder)
templateLength = defineTypeParameterizedTemplate templateCreator path t docs
where path = SymPath ["Array"] "length"
t = FuncTy [RefTy (StructTy (ConcreteNameTy "Array") [VarTy "t"]) (VarTy "q")] IntTy StaticLifetimeTy
docs = "gets the length of the array."
templateCreator = TemplateCreator $
\typeEnv env ->
Template
t
(const (toTemplate "int $NAME (Array *a)"))
(const (toTemplate "$DECL { return (*a).len; }"))
(\(FuncTy [RefTy arrayType _] _ _) ->
depsForDeleteFunc typeEnv env arrayType)
where
path = SymPath ["Array"] "length"
t = FuncTy [RefTy (StructTy (ConcreteNameTy "Array") [VarTy "t"]) (VarTy "q")] IntTy StaticLifetimeTy
docs = "gets the length of the array."
templateCreator = TemplateCreator $
\typeEnv env ->
Template
t
(const (toTemplate "int $NAME (Array *a)"))
(const (toTemplate "$DECL { return (*a).len; }"))
( \(FuncTy [RefTy arrayType _] _ _) ->
depsForDeleteFunc typeEnv env arrayType
)
templateAllocate :: (String, Binder)
templateAllocate = defineTypeParameterizedTemplate templateCreator path t docs
where path = SymPath ["Array"] "allocate"
t = FuncTy [IntTy] (StructTy (ConcreteNameTy "Array") [VarTy "t"]) StaticLifetimeTy
docs = "allocates an uninitialized array. You can initialize members using [`aset-uninitialized`](#aset-uninitialized)."
templateCreator = TemplateCreator $
\typeEnv env ->
Template
t
(const (toTemplate "Array $NAME (int n)"))
(\(FuncTy [_] arrayType _) ->
toTemplate $ unlines (["$DECL {"
," Array a;"
," a.len = n;"
," a.capacity = n;"
," a.data = CARP_MALLOC(n*sizeof($t));"]
++ initTy arrayType ++
[" return a;"
,"}"]))
(\(FuncTy [_] arrayType _) ->
depsForDeleteFunc typeEnv env arrayType)
where
path = SymPath ["Array"] "allocate"
t = FuncTy [IntTy] (StructTy (ConcreteNameTy "Array") [VarTy "t"]) StaticLifetimeTy
docs = "allocates an uninitialized array. You can initialize members using [`aset-uninitialized`](#aset-uninitialized)."
templateCreator = TemplateCreator $
\typeEnv env ->
Template
t
(const (toTemplate "Array $NAME (int n)"))
( \(FuncTy [_] arrayType _) ->
toTemplate $
unlines
( [ "$DECL {",
" Array a;",
" a.len = n;",
" a.capacity = n;",
" a.data = CARP_MALLOC(n*sizeof($t));"
]
++ initTy arrayType
++ [ " return a;",
"}"
]
)
)
( \(FuncTy [_] arrayType _) ->
depsForDeleteFunc typeEnv env arrayType
)
templateDeleteArray :: (String, Binder)
templateDeleteArray = defineTypeParameterizedTemplate templateCreator path t docs
where path = SymPath ["Array"] "delete"
t = FuncTy [StructTy (ConcreteNameTy "Array") [VarTy "a"]] UnitTy StaticLifetimeTy
docs = "deletes an array. This function should usually not be called manually."
templateCreator = TemplateCreator $
\typeEnv env ->
Template
t
(const (toTemplate "void $NAME (Array a)"))
(\(FuncTy [arrayType] UnitTy _) ->
[TokDecl, TokC "{\n"] ++
deleteTy typeEnv env arrayType ++
[TokC "}\n"])
(\(FuncTy [(StructTy (ConcreteNameTy "Array") [insideType])] UnitTy _) ->
depsForDeleteFunc typeEnv env insideType)
where
path = SymPath ["Array"] "delete"
t = FuncTy [StructTy (ConcreteNameTy "Array") [VarTy "a"]] UnitTy StaticLifetimeTy
docs = "deletes an array. This function should usually not be called manually."
templateCreator = TemplateCreator $
\typeEnv env ->
Template
t
(const (toTemplate "void $NAME (Array a)"))
( \(FuncTy [arrayType] UnitTy _) ->
[TokDecl, TokC "{\n"]
++ deleteTy typeEnv env arrayType
++ [TokC "}\n"]
)
( \(FuncTy [(StructTy (ConcreteNameTy "Array") [insideType])] UnitTy _) ->
depsForDeleteFunc typeEnv env insideType
)
deleteTy :: TypeEnv -> Env -> Ty -> [Token]
deleteTy typeEnv env (StructTy _ [innerType]) =
[ TokC " for(int i = 0; i < a.len; i++) {\n"
, TokC $ " " ++ insideArrayDeletion typeEnv env innerType "i"
, TokC " }\n"
, TokC " CARP_FREE(a.data);\n"
[ TokC " for(int i = 0; i < a.len; i++) {\n",
TokC $ " " ++ insideArrayDeletion typeEnv env innerType "i",
TokC " }\n",
TokC " CARP_FREE(a.data);\n"
]
deleteTy _ _ _ = []
initTy :: Ty -> [String]
initTy (StructTy (ConcreteNameTy "Array") [innerType@FuncTy{}]) =
[ " // initialize each Lambda struct "
, " for(int i = 0; i < a.len; i++) {"
, " " ++ insideArrayInitLambda innerType "i"
, " }"
initTy (StructTy (ConcreteNameTy "Array") [innerType@FuncTy {}]) =
[ " // initialize each Lambda struct ",
" for(int i = 0; i < a.len; i++) {",
" " ++ insideArrayInitLambda innerType "i",
" }"
]
initTy _ = []
insideArrayInitLambda :: Ty -> String -> String
insideArrayInitLambda t indexer =
" Lambda lambda = " ++ initLambda ++ "\n" ++
" ((" ++ tyToCLambdaFix t ++ "*)a.data)[" ++ indexer ++ "] = lambda;"
" Lambda lambda = " ++ initLambda ++ "\n"
++ " (("
++ tyToCLambdaFix t
++ "*)a.data)["
++ indexer
++ "] = lambda;"
initLambda :: String
initLambda = "{ .callback = NULL, .env = NULL, .delete = NULL, .copy = NULL };"
@ -355,46 +414,53 @@ insideArrayDeletion typeEnv env t indexer =
templateCopyArray :: (String, Binder)
templateCopyArray = defineTypeParameterizedTemplate templateCreator path t docs
where path = SymPath ["Array"] "copy"
t = FuncTy [RefTy (StructTy (ConcreteNameTy "Array") [VarTy "a"]) (VarTy "q")] (StructTy (ConcreteNameTy "Array") [VarTy "a"]) StaticLifetimeTy
docs = "copies an array."
templateCreator = TemplateCreator $
\typeEnv env ->
Template
t
(const (toTemplate "Array $NAME (Array* a)"))
(\(FuncTy [RefTy arrayType _] _ _) ->
[TokDecl, TokC "{\n"] ++
[TokC " Array copy;\n"] ++
[TokC " copy.len = a->len;\n"] ++
[TokC " copy.capacity = a->capacity;\n"] ++
[TokC " copy.data = CARP_MALLOC(sizeof(", TokTy (VarTy "a") Normal, TokC ") * a->capacity);\n"] ++
copyTy typeEnv env arrayType ++
[TokC " return copy;\n"] ++
[TokC "}\n"])
(\case
(FuncTy [RefTy arrayType@(StructTy (ConcreteNameTy "Array") [insideType]) _] _ _) ->
depsForCopyFunc typeEnv env insideType ++
depsForDeleteFunc typeEnv env arrayType
err ->
error ("CAN'T MATCH: " ++ show err))
where
path = SymPath ["Array"] "copy"
t = FuncTy [RefTy (StructTy (ConcreteNameTy "Array") [VarTy "a"]) (VarTy "q")] (StructTy (ConcreteNameTy "Array") [VarTy "a"]) StaticLifetimeTy
docs = "copies an array."
templateCreator = TemplateCreator $
\typeEnv env ->
Template
t
(const (toTemplate "Array $NAME (Array* a)"))
( \(FuncTy [RefTy arrayType _] _ _) ->
[TokDecl, TokC "{\n"]
++ [TokC " Array copy;\n"]
++ [TokC " copy.len = a->len;\n"]
++ [TokC " copy.capacity = a->capacity;\n"]
++ [TokC " copy.data = CARP_MALLOC(sizeof(", TokTy (VarTy "a") Normal, TokC ") * a->capacity);\n"]
++ copyTy typeEnv env arrayType
++ [TokC " return copy;\n"]
++ [TokC "}\n"]
)
( \case
(FuncTy [RefTy arrayType@(StructTy (ConcreteNameTy "Array") [insideType]) _] _ _) ->
depsForCopyFunc typeEnv env insideType
++ depsForDeleteFunc typeEnv env arrayType
err ->
error ("CAN'T MATCH: " ++ show err)
)
copyTy :: TypeEnv -> Env -> Ty -> [Token]
copyTy typeEnv env (StructTy (ConcreteNameTy "Array") [innerType]) =
if managed
then
[ TokC " for(int i = 0; i < a->len; i++) {\n"
, TokC $ " " ++ insideArrayCopying typeEnv env innerType
, TokC " }\n"
]
else
[TokC " memcpy(copy.data, a->data, sizeof(", TokTy (VarTy "a") Normal, TokC ") * a->len);\n"]
where managed =
case findFunctionForMember typeEnv env "delete"
(typesDeleterFunctionType innerType) ("Inside array.", innerType) of
FunctionFound _ -> True
FunctionNotFound _ -> False
FunctionIgnored -> False
then
[ TokC " for(int i = 0; i < a->len; i++) {\n",
TokC $ " " ++ insideArrayCopying typeEnv env innerType,
TokC " }\n"
]
else [TokC " memcpy(copy.data, a->data, sizeof(", TokTy (VarTy "a") Normal, TokC ") * a->len);\n"]
where
managed =
case findFunctionForMember
typeEnv
env
"delete"
(typesDeleterFunctionType innerType)
("Inside array.", innerType) of
FunctionFound _ -> True
FunctionNotFound _ -> False
FunctionIgnored -> False
copyTy _ _ _ = []
-- | The "memberCopy" and "memberDeletion" functions in Deftype are very similar!
@ -409,77 +475,83 @@ insideArrayCopying typeEnv env t =
templateStrArray :: (String, Binder)
templateStrArray = defineTypeParameterizedTemplate templateCreator path t docs
where templateCreator = TemplateCreator $
\typeEnv env ->
Template
t
(const (toTemplate "String $NAME (Array* a)"))
(\(FuncTy [RefTy arrayType _] StringTy _) ->
[TokDecl, TokC " {\n"] ++
strTy typeEnv env arrayType ++
[TokC "}\n"])
(\(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
docs = "converts an array to a string."
where
templateCreator = TemplateCreator $
\typeEnv env ->
Template
t
(const (toTemplate "String $NAME (Array* a)"))
( \(FuncTy [RefTy arrayType _] StringTy _) ->
[TokDecl, TokC " {\n"]
++ strTy typeEnv env arrayType
++ [TokC "}\n"]
)
( \(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
docs = "converts an array to a string."
-- | TODO: move this into the templateStrArray function?
strTy :: TypeEnv -> Env -> Ty -> [Token]
strTy typeEnv env (StructTy _ [innerType]) =
[ TokC ""
, TokC " String temp = NULL;\n"
, TokC $ calculateStrSize typeEnv env innerType
, TokC " String buffer = CARP_MALLOC(size);\n"
, TokC " String bufferPtr = buffer;\n"
, TokC "\n"
, TokC " sprintf(buffer, \"[\");\n"
, TokC " bufferPtr += 1;\n"
, TokC "\n"
, TokC " for(int i = 0; i < a->len; i++) {\n"
, TokC $ " " ++ insideArrayStr typeEnv env innerType
, TokC " }\n"
, TokC "\n"
, TokC " if(a->len > 0) { bufferPtr -= 1; }\n"
, TokC " sprintf(bufferPtr, \"]\");\n"
, TokC " return buffer;\n"
[ TokC "",
TokC " String temp = NULL;\n",
TokC $ calculateStrSize typeEnv env innerType,
TokC " String buffer = CARP_MALLOC(size);\n",
TokC " String bufferPtr = buffer;\n",
TokC "\n",
TokC " sprintf(buffer, \"[\");\n",
TokC " bufferPtr += 1;\n",
TokC "\n",
TokC " for(int i = 0; i < a->len; i++) {\n",
TokC $ " " ++ insideArrayStr typeEnv env innerType,
TokC " }\n",
TokC "\n",
TokC " if(a->len > 0) { bufferPtr -= 1; }\n",
TokC " sprintf(bufferPtr, \"]\");\n",
TokC " return buffer;\n"
]
strTy _ _ _ = []
calculateStrSize :: TypeEnv -> Env -> Ty -> String
calculateStrSize typeEnv env t =
unlines [ " int size = 3; // opening and closing brackets and terminator"
, " for(int i = 0; i < a->len; i++) {"
, arrayMemberSizeCalc ++ " }"
, ""
]
where arrayMemberSizeCalc =
case findFunctionForMemberIncludePrimitives typeEnv env "prn" (typesStrFunctionType typeEnv t) ("Inside array.", t) of
FunctionFound functionFullName ->
let takeAddressOrNot = if isManaged typeEnv t then "&" else ""
in unlines [ " temp = " ++ functionFullName ++ "(" ++ takeAddressOrNot ++ "((" ++ tyToC t ++ "*)a->data)[i]);"
, " size += snprintf(NULL, 0, \"%s \", temp);"
, " if(temp) {"
, " CARP_FREE(temp);"
, " temp = NULL;"
, " }"
]
FunctionNotFound msg -> error msg
FunctionIgnored -> " /* Ignore type inside Array: '" ++ show t ++ "' ??? */\n"
unlines
[ " int size = 3; // opening and closing brackets and terminator",
" for(int i = 0; i < a->len; i++) {",
arrayMemberSizeCalc ++ " }",
""
]
where
arrayMemberSizeCalc =
case findFunctionForMemberIncludePrimitives typeEnv env "prn" (typesStrFunctionType typeEnv t) ("Inside array.", t) of
FunctionFound functionFullName ->
let takeAddressOrNot = if isManaged typeEnv t then "&" else ""
in unlines
[ " temp = " ++ functionFullName ++ "(" ++ takeAddressOrNot ++ "((" ++ tyToC t ++ "*)a->data)[i]);",
" size += snprintf(NULL, 0, \"%s \", temp);",
" if(temp) {",
" CARP_FREE(temp);",
" temp = NULL;",
" }"
]
FunctionNotFound msg -> error msg
FunctionIgnored -> " /* Ignore type inside Array: '" ++ show t ++ "' ??? */\n"
insideArrayStr :: TypeEnv -> Env -> Ty -> String
insideArrayStr typeEnv env t =
case findFunctionForMemberIncludePrimitives typeEnv env "prn" (typesStrFunctionType typeEnv t) ("Inside array.", t) of
FunctionFound functionFullName ->
let takeAddressOrNot = if isManaged typeEnv t then "&" else ""
in unlines [ " temp = " ++ functionFullName ++ "(" ++ takeAddressOrNot ++ "((" ++ tyToC t ++ "*)a->data)[i]);"
, " sprintf(bufferPtr, \"%s \", temp);"
, " bufferPtr += strlen(temp) + 1;"
, " if(temp) {"
, " CARP_FREE(temp);"
, " temp = NULL;"
, " }"
]
in unlines
[ " temp = " ++ functionFullName ++ "(" ++ takeAddressOrNot ++ "((" ++ tyToC t ++ "*)a->data)[i]);",
" sprintf(bufferPtr, \"%s \", temp);",
" bufferPtr += strlen(temp) + 1;",
" if(temp) {",
" CARP_FREE(temp);",
" temp = NULL;",
" }"
]
FunctionNotFound msg -> error msg
FunctionIgnored -> " /* Ignore type inside Array: '" ++ show t ++ "' ??? */\n"

50
src/AssignTypes.hs
View File

@ -1,12 +1,13 @@
module AssignTypes where
import Types
import Obj
import TypeError
import Data.List (nub)
import qualified Data.Map as Map
import Obj
import TypeError
import Types
{-# ANN assignTypes "HLint: ignore Eta reduce" #-}
-- | Walk the whole expression tree and replace all occurences of VarTy with their corresponding actual type.
assignTypes :: TypeMappings -> XObj -> Either TypeError XObj
assignTypes mappings root = visit root
@ -17,52 +18,53 @@ assignTypes mappings root = visit root
(Arr _) -> visitArray xobj
(StaticArr _) -> visitStaticArray xobj
_ -> assignType xobj
visitList :: XObj -> Either TypeError XObj
visitList (XObj (Lst xobjs) i t) =
do visited <- mapM (assignTypes mappings) xobjs
let xobj' = XObj (Lst visited) i t
assignType xobj'
do
visited <- mapM (assignTypes mappings) xobjs
let xobj' = XObj (Lst visited) i t
assignType xobj'
visitList _ = error "The function 'visitList' only accepts XObjs with lists in them."
visitArray :: XObj -> Either TypeError XObj
visitArray (XObj (Arr xobjs) i t) =
do visited <- mapM (assignTypes mappings) xobjs
let xobj' = XObj (Arr visited) i t
assignType xobj'
do
visited <- mapM (assignTypes mappings) xobjs
let xobj' = XObj (Arr visited) i t
assignType xobj'
visitArray _ = error "The function 'visitArray' only accepts XObjs with arrays in them."
visitStaticArray :: XObj -> Either TypeError XObj
visitStaticArray (XObj (StaticArr xobjs) i t) =
do visited <- mapM (assignTypes mappings) xobjs
let xobj' = XObj (StaticArr visited) i t
assignType xobj'
do
visited <- mapM (assignTypes mappings) xobjs
let xobj' = XObj (StaticArr visited) i t
assignType xobj'
visitStaticArray _ = error "The function 'visitStaticArray' only accepts XObjs with arrays in them."
assignType :: XObj -> Either TypeError XObj
assignType xobj = case xobjTy xobj of
Just startingType ->
let finalType = replaceTyVars mappings startingType
in if isArrayTypeOK finalType
then Right (xobj { xobjTy = Just finalType })
else Left (ArraysCannotContainRefs xobj)
in if isArrayTypeOK finalType
then Right (xobj {xobjTy = Just finalType})
else Left (ArraysCannotContainRefs xobj)
Nothing -> pure xobj
isArrayTypeOK :: Ty -> Bool
isArrayTypeOK (StructTy (ConcreteNameTy "Array") [RefTy _ _]) = False -- An array containing refs!
isArrayTypeOK _ = True
-- | Change auto generated type names (i.e. 't0') to letters (i.e. 'a', 'b', 'c', etc...)
-- | TODO: Only change variables that are machine generated.
beautifyTypeVariables :: XObj -> Either TypeError XObj
beautifyTypeVariables root =
let Just t = xobjTy root
tys = nub (typeVariablesInOrderOfAppearance t)
mappings = Map.fromList (zip (map (\(VarTy name) -> name) tys)
(map (VarTy . (:[])) ['a'..]))
in assignTypes mappings root
mappings =
Map.fromList
( zip
(map (\(VarTy name) -> name) tys)
(map (VarTy . (: [])) ['a' ..])
)
in assignTypes mappings root
typeVariablesInOrderOfAppearance :: Ty -> [Ty]
typeVariablesInOrderOfAppearance (FuncTy argTys retTy ltTy) =

13
src/ColorText.hs
View File

@ -1,9 +1,8 @@
module ColorText where
import System.Console.ANSI hiding (Blue, Red, Yellow, Green, White)
import System.Console.ANSI hiding (Blue, Green, Red, White, Yellow)
import System.Exit (exitFailure)
import System.IO
import Util
data TextColor = Blue | Red | Yellow | Green | White
@ -15,11 +14,11 @@ strWithColor color str =
_ -> "\x1b[" ++ col ++ "m" ++ str ++ "\x1b[0m"
where
col = case color of
Red -> "31"
Green -> "32"
Yellow -> "33"
Blue -> "34"
White -> "37" -- TODO: Use 0 instead?
Red -> "31"
Green -> "32"
Yellow -> "33"
Blue -> "34"
White -> "37" -- TODO: Use 0 instead?
putStrWithColor :: TextColor -> String -> IO ()
putStrWithColor color str =

646
src/Commands.hs
View File

@ -1,37 +1,35 @@
module Commands where
import Prelude hiding (abs)
import ColorText
import Control.Exception
import Control.Monad (join, when)
import Control.Monad.IO.Class (liftIO, MonadIO)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Bits (finiteBitSize)
import Data.List (elemIndex)
import Data.List.Split (splitOn)
import Data.Maybe (fromMaybe)
import System.Exit (exitSuccess, ExitCode(..))
import System.Info (os, arch)
import System.Process (callCommand, spawnCommand, waitForProcess)
import System.IO (openFile, hPutStr, hClose, utf8, hSetEncoding, IOMode(..))
import System.Directory (makeAbsolute)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
import Emit
import Obj
import Project
import Types
import ColorText
import Util
import Lookup
import RenderDocs
import TypeError
import Path
import Info
import Lookup
import qualified Meta
import Obj
import Path
import Project
import Reify
import RenderDocs
import System.Directory (makeAbsolute)
import System.Exit (ExitCode (..), exitSuccess)
import System.IO (IOMode (..), hClose, hPutStr, hSetEncoding, openFile, utf8)
import System.Info (arch, os)
import System.Process (callCommand, spawnCommand, waitForProcess)
import TypeError
import Types
import Util
import Prelude hiding (abs)
data CarpException =
ShellOutException { shellOutMessage :: String, returnCode :: Int }
data CarpException
= ShellOutException {shellOutMessage :: String, returnCode :: Int}
| CancelEvaluationException
| EvalException EvalError
deriving (Eq, Show)
@ -59,101 +57,131 @@ addCommand name arity callback doc example = addCommandConfigurable name (Just a
addCommandConfigurable :: SymPath -> Maybe Int -> CommandCallback -> String -> String -> (String, Binder)
addCommandConfigurable path maybeArity callback doc example =
let cmd = XObj (Lst [XObj (Command (CommandFunction f)) (Just dummyInfo) Nothing
,XObj (Sym path Symbol) Nothing Nothing
,unfoldArgs
])
(Just dummyInfo) (Just DynamicTy)
let cmd =
XObj
( Lst
[ XObj (Command (CommandFunction f)) (Just dummyInfo) Nothing,
XObj (Sym path Symbol) Nothing Nothing,
unfoldArgs
]
)
(Just dummyInfo)
(Just DynamicTy)
SymPath _ name = path
meta = Meta.set "doc" (XObj (Str docString) Nothing Nothing) emptyMeta
in (name, Binder meta cmd)
where f = case maybeArity of
Just arity -> withArity arity
Nothing -> callback
docString = doc ++ "\n\n" ++ exampleUsage
exampleUsage = "Example Usage:\n```\n" ++ example ++ "\n```\n"
withArity arity ctx args =
if length args == arity
then callback ctx args
else
pure (evalError ctx ("Invalid args to '" ++ show path ++ "' command: " ++ joinWithComma (map pretty args) ++ "\n\n" ++ exampleUsage) Nothing)
unfoldArgs =
case maybeArity of
Just arity ->
let tosym x = (XObj (Sym (SymPath [] x) Symbol) Nothing Nothing)
in XObj (Arr (map (tosym . intToArgName) [1..arity])) Nothing Nothing
Nothing -> XObj (Arr [(XObj (Sym (SymPath [] "") Symbol) Nothing Nothing)]) Nothing Nothing
in (name, Binder meta cmd)
where
f = case maybeArity of
Just arity -> withArity arity
Nothing -> callback
docString = doc ++ "\n\n" ++ exampleUsage
exampleUsage = "Example Usage:\n```\n" ++ example ++ "\n```\n"
withArity arity ctx args =
if length args == arity
then callback ctx args
else pure (evalError ctx ("Invalid args to '" ++ show path ++ "' command: " ++ joinWithComma (map pretty args) ++ "\n\n" ++ exampleUsage) Nothing)
unfoldArgs =
case maybeArity of
Just arity ->
let tosym x = (XObj (Sym (SymPath [] x) Symbol) Nothing Nothing)
in XObj (Arr (map (tosym . intToArgName) [1 .. arity])) Nothing Nothing
Nothing -> XObj (Arr [(XObj (Sym (SymPath [] "") Symbol) Nothing Nothing)]) Nothing Nothing
presentErrorWithLabel :: MonadIO m => String -> String -> a -> m a
presentErrorWithLabel label msg ret =
liftIO $ do emitErrorWithLabel label msg
pure ret
liftIO $ do
emitErrorWithLabel label msg
pure ret
presentError :: MonadIO m => String -> a -> m a
presentError msg ret =
liftIO $ do emitError msg
pure ret
liftIO $ do
emitError msg
pure ret
-- | Command for changing various project settings.
commandProjectConfig :: CommandCallback
commandProjectConfig ctx [xobj@(XObj (Str key) _ _), value] = do
let proj = contextProj ctx
newProj = case key of
"cflag" -> do cflag <- unwrapStringXObj value
pure (proj { projectCFlags = addIfNotPresent cflag (projectCFlags proj) })
"libflag" -> do libflag <- unwrapStringXObj value
pure (proj { projectLibFlags = addIfNotPresent libflag (projectLibFlags proj) })
"pkgconfigflag" -> do pkgconfigflag <- unwrapStringXObj value
pure (proj { projectPkgConfigFlags = addIfNotPresent pkgconfigflag (projectPkgConfigFlags proj) })
"cmod" -> do cmod <- unwrapStringXObj value
pure (proj { projectCModules = addIfNotPresent cmod (projectCModules proj) })
"prompt" -> do prompt <- unwrapStringXObj value
pure (proj { projectPrompt = prompt })
"search-path" -> do searchPath <- unwrapStringXObj value
pure (proj { projectCarpSearchPaths = addIfNotPresent searchPath (projectCarpSearchPaths proj) })
"print-ast" -> do printAST <- unwrapBoolXObj value
pure (proj { projectPrintTypedAST = printAST })
"echo-c" -> do echoC <- unwrapBoolXObj value
pure (proj { projectEchoC = echoC })
"echo-compiler-cmd" -> do echoCompilerCmd <- unwrapBoolXObj value
pure (proj { projectEchoCompilationCommand = echoCompilerCmd })
"compiler" -> do compiler <- unwrapStringXObj value
pure (proj { projectCompiler = compiler })
"target" -> do target <- unwrapStringXObj value
pure (proj { projectTarget = Target target })
"title" -> do title <- unwrapStringXObj value
pure (proj { projectTitle = title })
"output-directory" -> do outDir <- unwrapStringXObj value
pure (proj { projectOutDir = outDir })
"docs-directory" -> do docsDir <- unwrapStringXObj value
pure (proj { projectDocsDir = docsDir })
"docs-generate-index" ->
do docsGenerateIndex <- unwrapBoolXObj value
pure (proj { projectDocsGenerateIndex = docsGenerateIndex })
"docs-logo" -> do logo <- unwrapStringXObj value
pure (proj { projectDocsLogo = logo })
"docs-prelude" -> do prelude <- unwrapStringXObj value
pure (proj { projectDocsPrelude = prelude })
"docs-url" -> do url <- unwrapStringXObj value
pure (proj { projectDocsURL = url })
"docs-styling" -> do url <- unwrapStringXObj value
pure (proj { projectDocsStyling = url })
"file-path-print-length" -> do len <- unwrapStringXObj value
case len of
"short" -> pure (proj { projectFilePathPrintLength = ShortPath })
"full" -> pure (proj { projectFilePathPrintLength = ShortPath })
_ -> Left ("Project.config can't understand the value '" ++ len ++ "' for key 'file-path-print-length.")
"generate-only" -> do generateOnly <- unwrapBoolXObj value
pure (proj { projectGenerateOnly = generateOnly })
"paren-balance-hints" ->
do balanceHints <- unwrapBoolXObj value
pure (proj { projectBalanceHints = balanceHints })
"force-reload" -> do forceReload <- unwrapBoolXObj value
pure (proj { projectForceReload = forceReload })
_ -> Left ("Project.config can't understand the key '" ++ key ++ "' at " ++ prettyInfoFromXObj xobj ++ ".")
"cflag" -> do
cflag <- unwrapStringXObj value
pure (proj {projectCFlags = addIfNotPresent cflag (projectCFlags proj)})
"libflag" -> do
libflag <- unwrapStringXObj value
pure (proj {projectLibFlags = addIfNotPresent libflag (projectLibFlags proj)})
"pkgconfigflag" -> do
pkgconfigflag <- unwrapStringXObj value
pure (proj {projectPkgConfigFlags = addIfNotPresent pkgconfigflag (projectPkgConfigFlags proj)})
"cmod" -> do
cmod <- unwrapStringXObj value
pure (proj {projectCModules = addIfNotPresent cmod (projectCModules proj)})
"prompt" -> do
prompt <- unwrapStringXObj value
pure (proj {projectPrompt = prompt})
"search-path" -> do
searchPath <- unwrapStringXObj value
pure (proj {projectCarpSearchPaths = addIfNotPresent searchPath (projectCarpSearchPaths proj)})
"print-ast" -> do
printAST <- unwrapBoolXObj value
pure (proj {projectPrintTypedAST = printAST})
"echo-c" -> do
echoC <- unwrapBoolXObj value
pure (proj {projectEchoC = echoC})
"echo-compiler-cmd" -> do
echoCompilerCmd <- unwrapBoolXObj value
pure (proj {projectEchoCompilationCommand = echoCompilerCmd})
"compiler" -> do
compiler <- unwrapStringXObj value
pure (proj {projectCompiler = compiler})
"target" -> do
target <- unwrapStringXObj value
pure (proj {projectTarget = Target target})
"title" -> do
title <- unwrapStringXObj value
pure (proj {projectTitle = title})
"output-directory" -> do
outDir <- unwrapStringXObj value
pure (proj {projectOutDir = outDir})
"docs-directory" -> do
docsDir <- unwrapStringXObj value
pure (proj {projectDocsDir = docsDir})
"docs-generate-index" ->
do
docsGenerateIndex <- unwrapBoolXObj value
pure (proj {projectDocsGenerateIndex = docsGenerateIndex})
"docs-logo" -> do
logo <- unwrapStringXObj value
pure (proj {projectDocsLogo = logo})
"docs-prelude" -> do
prelude <- unwrapStringXObj value
pure (proj {projectDocsPrelude = prelude})
"docs-url" -> do
url <- unwrapStringXObj value
pure (proj {projectDocsURL = url})
"docs-styling" -> do
url <- unwrapStringXObj value
pure (proj {projectDocsStyling = url})
"file-path-print-length" -> do
len <- unwrapStringXObj value
case len of
"short" -> pure (proj {projectFilePathPrintLength = ShortPath})
"full" -> pure (proj {projectFilePathPrintLength = ShortPath})
_ -> Left ("Project.config can't understand the value '" ++ len ++ "' for key 'file-path-print-length.")
"generate-only" -> do
generateOnly <- unwrapBoolXObj value
pure (proj {projectGenerateOnly = generateOnly})
"paren-balance-hints" ->
do
balanceHints <- unwrapBoolXObj value
pure (proj {projectBalanceHints = balanceHints})
"force-reload" -> do
forceReload <- unwrapBoolXObj value
pure (proj {projectForceReload = forceReload})
_ -> Left ("Project.config can't understand the key '" ++ key ++ "' at " ++ prettyInfoFromXObj xobj ++ ".")
case newProj of
Left errorMessage -> presentErrorWithLabel "CONFIG ERROR" errorMessage (ctx, dynamicNil)
Right ok -> pure (ctx {contextProj=ok}, dynamicNil)
Right ok -> pure (ctx {contextProj = ok}, dynamicNil)
commandProjectConfig ctx [faultyKey, _] =
presentError ("First argument to 'Project.config' must be a string: " ++ pretty faultyKey) (ctx, dynamicNil)
@ -163,49 +191,50 @@ commandProjectGetConfig ctx [xobj@(XObj (Str key) _ _)] =
let proj = contextProj ctx
xstr s = XObj s (Just dummyInfo) (Just StringTy)
getVal _ = case key of
"cflag" -> Right $ Str $ show $ projectCFlags proj
"libflag" -> Right $ Str $ show $ projectLibFlags proj
"pkgconfigflag" -> Right $ Arr $ xstr . Str <$> projectPkgConfigFlags proj
"load-stack" -> Right $ Arr $ xstr . Str <$> projectLoadStack proj
"prompt" -> Right $ Str $ projectPrompt proj
"search-path" -> Right $ Str $ show $ projectCarpSearchPaths proj
"print-ast" -> Right $ Bol $ projectPrintTypedAST proj
"echo-c" -> Right $ Bol $ projectEchoC proj
"echo-compiler-cmd" -> Right $ Bol $ projectEchoCompilationCommand proj
"compiler" -> Right $ Str $ projectCompiler proj
"target" -> Right $ Str $ show $ projectTarget proj
"title" -> Right $ Str $ projectTitle proj
"output-directory" -> Right $ Str $ projectOutDir proj
"docs-directory" -> Right $ Str $ projectDocsDir proj
"docs-logo" -> Right $ Str $ projectDocsLogo proj
"docs-prelude" -> Right $ Str $ projectDocsPrelude proj
"docs-url" -> Right $ Str $ projectDocsURL proj
"docs-generate-index" -> Right $ Bol $ projectDocsGenerateIndex proj
"docs-styling" -> Right $ Str $ projectDocsStyling proj
"file-path-print-length" -> Right $ Str $ show (projectFilePathPrintLength proj)
"generate-only" -> Right $ Bol $ projectGenerateOnly proj
"paren-balance-hints" -> Right $ Bol $ projectBalanceHints proj
_ -> Left key
in pure $ case getVal ctx of
Right val -> (ctx, Right $ xstr val)
Left k -> (evalError ctx (labelStr "CONFIG ERROR" ("Project.get-config can't understand the key '" ++ k)) (xobjInfo xobj))
"cflag" -> Right $ Str $ show $ projectCFlags proj
"libflag" -> Right $ Str $ show $ projectLibFlags proj
"pkgconfigflag" -> Right $ Arr $ xstr . Str <$> projectPkgConfigFlags proj
"load-stack" -> Right $ Arr $ xstr . Str <$> projectLoadStack proj
"prompt" -> Right $ Str $ projectPrompt proj
"search-path" -> Right $ Str $ show $ projectCarpSearchPaths proj
"print-ast" -> Right $ Bol $ projectPrintTypedAST proj
"echo-c" -> Right $ Bol $ projectEchoC proj
"echo-compiler-cmd" -> Right $ Bol $ projectEchoCompilationCommand proj
"compiler" -> Right $ Str $ projectCompiler proj
"target" -> Right $ Str $ show $ projectTarget proj
"title" -> Right $ Str $ projectTitle proj
"output-directory" -> Right $ Str $ projectOutDir proj
"docs-directory" -> Right $ Str $ projectDocsDir proj
"docs-logo" -> Right $ Str $ projectDocsLogo proj
"docs-prelude" -> Right $ Str $ projectDocsPrelude proj
"docs-url" -> Right $ Str $ projectDocsURL proj
"docs-generate-index" -> Right $ Bol $ projectDocsGenerateIndex proj
"docs-styling" -> Right $ Str $ projectDocsStyling proj
"file-path-print-length" -> Right $ Str $ show (projectFilePathPrintLength proj)
"generate-only" -> Right $ Bol $ projectGenerateOnly proj
"paren-balance-hints" -> Right $ Bol $ projectBalanceHints proj
_ -> Left key
in pure $ case getVal ctx of
Right val -> (ctx, Right $ xstr val)
Left k -> (evalError ctx (labelStr "CONFIG ERROR" ("Project.get-config can't understand the key '" ++ k)) (xobjInfo xobj))
commandProjectGetConfig ctx [faultyKey] =
presentError ("First argument to 'Project.config' must be a string: " ++ pretty faultyKey) (ctx, dynamicNil)
-- | Command for exiting the REPL/compiler
commandQuit :: CommandCallback
commandQuit ctx _ =
do _ <- liftIO exitSuccess
pure (ctx, dynamicNil)
do
_ <- liftIO exitSuccess
pure (ctx, dynamicNil)
-- | Command for printing the generated C output (in out/main.c)
commandCat :: CommandCallback
commandCat ctx _ = do
let outDir = projectOutDir (contextProj ctx)
outMain = outDir </> "main.c"
liftIO $ do callCommand ("cat -n " ++ outMain)
pure (ctx, dynamicNil)
liftIO $ do
callCommand ("cat -n " ++ outMain)
pure (ctx, dynamicNil)
-- | Command for running the executable generated by the 'build' command.
commandRunExe :: CommandCallback
@ -215,13 +244,15 @@ commandRunExe ctx _ = do
quoted x = "\"" ++ x ++ "\""
outExe = quoted $ outDir </> projectTitle (contextProj ctx)
if projectCanExecute proj
then liftIO $ do hndl <- spawnCommand outExe
exitCode <- waitForProcess hndl
case exitCode of
ExitSuccess -> pure (ctx, Right (XObj (Num IntTy 0) (Just dummyInfo) (Just IntTy)))
ExitFailure i -> throw (ShellOutException ("'" ++ outExe ++ "' exited with return value " ++ show i ++ ".") i)
else liftIO $ do putStrLnWithColor Red "Can't call the 'run' command, need to build an executable first (requires a 'main' function)."
pure (ctx, dynamicNil)
then liftIO $ do
hndl <- spawnCommand outExe
exitCode <- waitForProcess hndl
case exitCode of
ExitSuccess -> pure (ctx, Right (XObj (Num IntTy 0) (Just dummyInfo) (Just IntTy)))
ExitFailure i -> throw (ShellOutException ("'" ++ outExe ++ "' exited with return value " ++ show i ++ ".") i)
else liftIO $ do
putStrLnWithColor Red "Can't call the 'run' command, need to build an executable first (requires a 'main' function)."
pure (ctx, dynamicNil)
-- | Command for building the project, producing an executable binary or a shared library.
commandBuild :: Bool -> Context -> [XObj] -> IO (Context, Either EvalError XObj)
@ -230,75 +261,88 @@ commandBuild shutUp ctx _ = do
typeEnv = contextTypeEnv ctx
proj = contextProj ctx
execMode = contextExecMode ctx
src = do decl <- envToDeclarations typeEnv env
typeDecl <- envToDeclarations typeEnv (getTypeEnv typeEnv)
c <- envToC env Functions
initGlobals <- fmap (wrapInInitFunction (projectCore proj)) (globalsToC env)
pure ("//Types:\n" ++ typeDecl ++
"\n\n//Declarations:\n" ++ decl ++
"\n\n//Init globals:\n" ++ initGlobals ++
"\n\n//Definitions:\n" ++ c
)
src = do
decl <- envToDeclarations typeEnv env
typeDecl <- envToDeclarations typeEnv (getTypeEnv typeEnv)
c <- envToC env Functions
initGlobals <- fmap (wrapInInitFunction (projectCore proj)) (globalsToC env)
pure
( "//Types:\n" ++ typeDecl
++ "\n\n//Declarations:\n"
++ decl
++ "\n\n//Init globals:\n"
++ initGlobals
++ "\n\n//Definitions:\n"
++ c
)
case src of
Left err ->
pure (evalError ctx ("I encountered an error when emitting code:\n\n" ++ show err) Nothing)
Right okSrc ->
do let compiler = projectCompiler proj
echoCompilationCommand = projectEchoCompilationCommand proj
incl = projectIncludesToC proj
includeCorePath = projectCarpDir proj ++ "/core/ "
cModules = projectCModules proj
flags = projectFlags proj
outDir = projectOutDir proj
outMain = outDir </> "main.c"
outExe = outDir </> projectTitle proj
generateOnly = projectGenerateOnly proj
compile hasMain =
do let cmd = joinWithSpace $ [ compiler
, if hasMain then "" else "-shared"
, "-o"
, outExe
, "-I"
, includeCorePath
, flags
, outMain
] ++ cModules
in liftIO $ do when echoCompilationCommand (putStrLn cmd)
callCommand cmd
when (execMode == Repl && not shutUp) $
(putStrLn ("Compiled to '" ++ outExe ++ (if hasMain then "' (executable)" else "' (shared library)")))
pure (setProjectCanExecute hasMain ctx, dynamicNil)
liftIO $ createDirectoryIfMissing False outDir
outputHandle <- openFile outMain WriteMode
hSetEncoding outputHandle utf8
hPutStr outputHandle (incl ++ okSrc)
hClose outputHandle
if generateOnly then pure (ctx, dynamicNil) else
case Map.lookup "main" (envBindings env) of
Just _ -> compile True
Nothing -> compile False
do
let compiler = projectCompiler proj
echoCompilationCommand = projectEchoCompilationCommand proj
incl = projectIncludesToC proj
includeCorePath = projectCarpDir proj ++ "/core/ "
cModules = projectCModules proj
flags = projectFlags proj
outDir = projectOutDir proj
outMain = outDir </> "main.c"
outExe = outDir </> projectTitle proj
generateOnly = projectGenerateOnly proj
compile hasMain =
do
let cmd =
joinWithSpace $
[ compiler,
if hasMain then "" else "-shared",
"-o",
outExe,
"-I",
includeCorePath,
flags,
outMain
]
++ cModules
in liftIO $ do
when echoCompilationCommand (putStrLn cmd)
callCommand cmd
when (execMode == Repl && not shutUp) $
(putStrLn ("Compiled to '" ++ outExe ++ (if hasMain then "' (executable)" else "' (shared library)")))
pure (setProjectCanExecute hasMain ctx, dynamicNil)
liftIO $ createDirectoryIfMissing False outDir
outputHandle <- openFile outMain WriteMode
hSetEncoding outputHandle utf8
hPutStr outputHandle (incl ++ okSrc)
hClose outputHandle
if generateOnly
then pure (ctx, dynamicNil)
else case Map.lookup "main" (envBindings env) of
Just _ -> compile True
Nothing -> compile False
setProjectCanExecute :: Bool -> Context -> Context
setProjectCanExecute value ctx =
let proj = contextProj ctx
proj' = proj { projectCanExecute = value }
in ctx { contextProj = proj' }
proj' = proj {projectCanExecute = value}
in ctx {contextProj = proj'}
-- | Command for printing all the bindings in the current environment.
commandListBindings :: CommandCallback
commandListBindings ctx _ =
liftIO $ do putStrLn "Types:\n"
putStrLn (prettyEnvironment (getTypeEnv (contextTypeEnv ctx)))
putStrLn "\nGlobal environment:\n"
putStrLn (prettyEnvironment (contextGlobalEnv ctx))
putStrLn ""
pure (ctx, dynamicNil)
liftIO $ do
putStrLn "Types:\n"
putStrLn (prettyEnvironment (getTypeEnv (contextTypeEnv ctx)))
putStrLn "\nGlobal environment:\n"
putStrLn (prettyEnvironment (contextGlobalEnv ctx))
putStrLn ""
pure (ctx, dynamicNil)
-- | Command for printing information about the current project.
commandProject :: CommandCallback
commandProject ctx _ = do
liftIO (print (contextProj ctx))
pure (ctx, dynamicNil)
liftIO (print (contextProj ctx))
pure (ctx, dynamicNil)
-- | Command for getting the name of the operating system you're on.
commandHostOS :: CommandCallback
@ -318,11 +362,12 @@ commandAddInclude includerConstructor ctx [x] =
let proj = contextProj ctx
includer = includerConstructor file
includers = projectIncludes proj
includers' = if includer `elem` includers
then includers
else includers ++ [includer] -- Add last to preserve include order
proj' = proj { projectIncludes = includers' }
pure (ctx { contextProj = proj' }, dynamicNil)
includers' =
if includer `elem` includers
then includers
else includers ++ [includer] -- Add last to preserve include order
proj' = proj {projectIncludes = includers'}
pure (ctx {contextProj = proj'}, dynamicNil)
_ ->
pure (evalError ctx ("Argument to 'include' must be a string, but was `" ++ pretty x ++ "`") (xobjInfo x))
@ -333,10 +378,12 @@ commandAddRelativeInclude :: CommandCallback
commandAddRelativeInclude ctx [x] =
case x of
XObj (Str file) i@(Just info) t ->
let compiledFile = infoFile info
in commandAddInclude RelativeInclude ctx [
XObj (Str $ takeDirectory compiledFile </> file) i t
]
let compiledFile = infoFile info
in commandAddInclude
RelativeInclude
ctx
[ XObj (Str $ takeDirectory compiledFile </> file) i t
]
_ ->
pure (evalError ctx ("Argument to 'include' must be a string, but was `" ++ pretty x ++ "`") (xobjInfo x))
@ -392,8 +439,8 @@ commandCdr ctx [x] =
commandLast :: CommandCallback
commandLast ctx [x] =
pure $ case x of
XObj (Lst lst@(_:_)) _ _ -> (ctx, Right (last lst))
XObj (Arr arr@(_:_)) _ _ -> (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." (xobjInfo x)
commandAllButLast :: CommandCallback
@ -430,17 +477,18 @@ commandMacroError :: CommandCallback
commandMacroError ctx [msg] =
pure $ case msg of
XObj (Str smsg) _ _ -> evalError ctx smsg (xobjInfo msg)
x -> evalError ctx (pretty x) (xobjInfo msg)
x -> evalError ctx (pretty x) (xobjInfo msg)
commandMacroLog :: CommandCallback
commandMacroLog ctx msgs = do
liftIO (mapM_ (putStr . logify) msgs)
liftIO (putStr "\n")
pure (ctx, dynamicNil)
where logify m =
case m of
XObj (Str msg) _ _ -> msg
x -> pretty x
where
logify m =
case m of
XObj (Str msg) _ _ -> msg
x -> pretty x
commandEq :: CommandCallback
commandEq ctx [a, b] =
@ -448,8 +496,9 @@ commandEq ctx [a, b] =
Left (a', b') -> evalError ctx ("Can't compare " ++ pretty a' ++ " with " ++ pretty b') (xobjInfo a')
Right b' -> (ctx, Right (boolToXObj b'))
where
cmp (XObj (Num aTy aNum) _ _, XObj (Num bTy bNum) _ _) | aTy == bTy =
Right $ aNum == bNum
cmp (XObj (Num aTy aNum) _ _, XObj (Num bTy bNum) _ _)
| aTy == bTy =
Right $ aNum == bNum
cmp (XObj (Str sa) _ _, XObj (Str sb) _ _) = Right $ sa == sb
cmp (XObj (Chr ca) _ _, XObj (Chr cb) _ _) = Right $ ca == cb
cmp (XObj (Sym sa _) _ _, XObj (Sym sb _) _ _) = Right $ sa == sb
@ -473,13 +522,13 @@ commandEq ctx [a, b] =
cmp (XObj (Lst []) _ _, XObj (Lst []) _ _) = Right True
cmp (XObj (Lst elemsA) _ _, XObj (Lst elemsB) _ _) =
if length elemsA == length elemsB
then foldr cmp' (Right True) (zip elemsA elemsB)
else Right False
then foldr cmp' (Right True) (zip elemsA elemsB)
else Right False
cmp (XObj (Arr []) _ _, XObj (Arr []) _ _) = Right True
cmp (XObj (Arr elemsA) _ _, XObj (Arr elemsB) _ _) =
if length elemsA == length elemsB
then foldr cmp' (Right True) (zip elemsA elemsB)
else Right False
then foldr cmp' (Right True) (zip elemsA elemsB)
else Right False
cmp invalid = Left invalid
cmp' _ invalid@(Left _) = invalid
cmp' _ (Right False) = Right False
@ -489,7 +538,6 @@ commandComp :: (Number -> Number -> Bool) -> String -> CommandCallback
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) (xobjInfo a)
commandLt :: CommandCallback
commandLt = commandComp (<) "<"
@ -501,8 +549,8 @@ commandCharAt ctx [a, b] =
pure $ case (a, b) of
(XObj (Str s) _ _, XObj (Num IntTy (Integral i)) _ _) ->
if length s > i
then (ctx, Right (XObj (Chr (s !! i)) (Just dummyInfo) (Just IntTy)))
else evalError ctx ("Can't call char-at with " ++ pretty a ++ " and " ++ show i ++ ", index too large") (xobjInfo a)
then (ctx, Right (XObj (Chr (s !! i)) (Just dummyInfo) (Just IntTy)))
else evalError ctx ("Can't call char-at with " ++ pretty a ++ " and " ++ show i ++ ", index too large") (xobjInfo a)
_ -> evalError ctx ("Can't call char-at with " ++ pretty a ++ " and " ++ pretty b) (xobjInfo a)
commandIndexOf :: CommandCallback
@ -511,7 +559,8 @@ commandIndexOf ctx [a, b] =
(XObj (Str s) _ _, XObj (Chr c) _ _) ->
(ctx, Right (XObj (Num IntTy (Integral (getIdx c s))) (Just dummyInfo) (Just IntTy)))
_ -> evalError ctx ("Can't call index-of with " ++ pretty a ++ " and " ++ pretty b) (xobjInfo a)
where getIdx c s = fromMaybe (-1) $ elemIndex c s
where
getIdx c s = fromMaybe (-1) $ elemIndex c s
commandSubstring :: CommandCallback
commandSubstring ctx [a, b, c] =
@ -539,7 +588,8 @@ commandStringConcat ctx [a] =
commandStringSplitOn :: CommandCallback
commandStringSplitOn ctx [XObj (Str sep) _ _, XObj (Str s) _ _] =
pure $ (ctx, Right (XObj (Arr (xstr <$> splitOn sep s)) (Just dummyInfo) Nothing))
where xstr o = XObj (Str o) (Just dummyInfo) (Just StringTy)
where
xstr o = XObj (Str o) (Just dummyInfo) (Just StringTy)
commandStringSplitOn ctx [sep, s] =
pure $ evalError ctx ("Can't call split-on with " ++ pretty sep ++ ", " ++ pretty s) (xobjInfo sep)
@ -594,10 +644,10 @@ commandPathAbsolute ctx [a] =
pure $ (ctx, Right (XObj (Str abs) (Just dummyInfo) (Just StringTy)))
_ -> pure $ evalError ctx ("Can't call `absolute` with " ++ pretty a) (xobjInfo a)
commandArith :: (Number -> Number -> Number) -> String -> CommandCallback
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 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) (xobjInfo a)
commandPlus :: CommandCallback
@ -617,13 +667,14 @@ commandMul = commandArith (*) "*"
commandStr :: CommandCallback
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 _) _ _) = show path
f x = escape $ pretty x
escape [] = []
escape ('\\':y) = "\\\\" ++ escape y
escape (x:y) = x : escape y
where
-- TODO: Is there a better function to call here than some exceptions + 'pretty'?
f (XObj (Str s) _ _) = s
f (XObj (Sym path _) _ _) = show path
f x = escape $ pretty x
escape [] = []
escape ('\\' : y) = "\\\\" ++ escape y
escape (x : y) = x : escape y
commandNot :: CommandCallback
commandNot ctx [x] =
@ -635,10 +686,10 @@ commandReadFile :: CommandCallback
commandReadFile ctx [filename] =
case filename of
XObj (Str fname) _ _ -> do
exceptional <- liftIO ((try $ slurp fname) :: (IO (Either IOException String)))
pure $ case exceptional of
Right contents -> (ctx, Right (XObj (Str contents) (Just dummyInfo) (Just StringTy)))
Left _ -> (evalError ctx ("The argument to `read-file` `" ++ fname ++ "` does not exist") (xobjInfo filename))
exceptional <- liftIO ((try $ slurp fname) :: (IO (Either IOException String)))
pure $ case exceptional of
Right contents -> (ctx, Right (XObj (Str contents) (Just dummyInfo) (Just StringTy)))
Left _ -> (evalError ctx ("The argument to `read-file` `" ++ fname ++ "` does not exist") (xobjInfo filename))
_ -> pure (evalError ctx ("The argument to `read-file` must be a string, I got `" ++ pretty filename ++ "`") (xobjInfo filename))
commandWriteFile :: CommandCallback
@ -647,8 +698,8 @@ commandWriteFile ctx [filename, contents] =
XObj (Str fname) _ _ ->
case contents of
XObj (Str s) _ _ -> do
exceptional <- liftIO ((try $ writeFile fname s) :: (IO (Either IOException ())))
pure $ case exceptional of
exceptional <- liftIO ((try $ writeFile fname s) :: (IO (Either IOException ())))
pure $ case exceptional of
Right () -> (ctx, dynamicNil)
Left _ -> evalError ctx ("Cannot write to argument to `" ++ fname ++ "`, an argument to `write-file`") (xobjInfo filename)
_ -> pure (evalError ctx ("The second argument to `write-file` must be a string, I got `" ++ pretty contents ++ "`") (xobjInfo contents))
@ -657,35 +708,36 @@ commandWriteFile ctx [filename, contents] =
commandHostBitWidth :: CommandCallback
commandHostBitWidth ctx [] =
let bitSize = Integral (finiteBitSize (undefined :: Int))
in pure (ctx, Right (XObj (Num IntTy bitSize) (Just dummyInfo) (Just IntTy)))
in pure (ctx, Right (XObj (Num IntTy bitSize) (Just dummyInfo) (Just IntTy)))
commandSaveDocsInternal :: CommandCallback
commandSaveDocsInternal ctx [modulePath] = do
let globalEnv = contextGlobalEnv ctx
case modulePath of
XObj (Lst xobjs) _ _ ->
case mapM unwrapSymPathXObj xobjs of
Left err -> pure (evalError ctx err (xobjInfo modulePath))
Right okPaths ->
case mapM (getEnvironmentBinderForDocumentation ctx globalEnv) okPaths of
Left err -> pure (evalError ctx err (xobjInfo modulePath))
Right okEnvBinders -> saveDocs ctx (zip okPaths okEnvBinders)
x ->
pure (evalError ctx ("Invalid arg to save-docs-internal (expected list of symbols): " ++ pretty x) (xobjInfo modulePath))
where getEnvironmentBinderForDocumentation :: Context -> Env -> SymPath -> Either String Binder
getEnvironmentBinderForDocumentation _ env path =
case lookupInEnv path env of
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")
Nothing ->
Left ("I can’t find the module `" ++ show path ++ "`")
let globalEnv = contextGlobalEnv ctx
case modulePath of
XObj (Lst xobjs) _ _ ->
case mapM unwrapSymPathXObj xobjs of
Left err -> pure (evalError ctx err (xobjInfo modulePath))
Right okPaths ->
case mapM (getEnvironmentBinderForDocumentation ctx globalEnv) okPaths of
Left err -> pure (evalError ctx err (xobjInfo modulePath))
Right okEnvBinders -> saveDocs ctx (zip okPaths okEnvBinders)
x ->
pure (evalError ctx ("Invalid arg to save-docs-internal (expected list of symbols): " ++ pretty x) (xobjInfo modulePath))
where
getEnvironmentBinderForDocumentation :: Context -> Env -> SymPath -> Either String Binder
getEnvironmentBinderForDocumentation _ env path =
case lookupInEnv path env of
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")
Nothing ->
Left ("I can’t find the module `" ++ show path ++ "`")
saveDocs :: Context -> [(SymPath, Binder)] -> IO (Context, Either a XObj)
saveDocs ctx pathsAndEnvBinders = do
liftIO (saveDocsForEnvs (contextProj ctx) pathsAndEnvBinders)
pure (ctx, dynamicNil)
liftIO (saveDocsForEnvs (contextProj ctx) pathsAndEnvBinders)
pure (ctx, dynamicNil)
commandSexpression :: CommandCallback
commandSexpression ctx [xobj, (XObj (Bol b) _ _)] =
@ -698,44 +750,54 @@ commandSexpression ctx xobj =
commandSexpressionInternal :: Context -> [XObj] -> Bool -> IO (Context, Either EvalError XObj)
commandSexpressionInternal ctx [xobj] bol =
let tyEnv = getTypeEnv $ contextTypeEnv ctx
in case xobj of
(XObj (Lst [inter@(XObj (Interface ty _) _ _), path]) i t) ->
pure (ctx, Right (XObj (Lst [(toSymbols inter), path, (reify ty)]) i t))
(XObj (Lst forms) i t) ->
pure (ctx, Right (XObj (Lst (map toSymbols forms)) i t))
mdl@(XObj (Mod e) _ _) ->
if bol
then getMod
else
case lookupInEnv (SymPath [] (fromMaybe "" (envModuleName e))) tyEnv of
Just (_, Binder _ (XObj (Lst forms) i t)) ->
pure (ctx, Right (XObj (Lst (map toSymbols forms)) i t))
Just (_, Binder _ xobj') ->
pure (ctx, Right (toSymbols xobj'))
Nothing ->
getMod
where getMod =
case (toSymbols mdl) of
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 _) _ _))) =
(c, Right (XObj (Lst (xs ++ [y])) i t))
combine _ (c, (Left err)) =
(c, Left err)
combine (c, Left err) _ =
(c, Left err)
_ ->
pure $ evalError ctx ("can't get an s-expression for: " ++ pretty xobj ++ " is it a bound symbol or literal s-expression?") (Just dummyInfo)
in case xobj of
(XObj (Lst [inter@(XObj (Interface ty _) _ _), path]) i t) ->
pure (ctx, Right (XObj (Lst [(toSymbols inter), path, (reify ty)]) i t))
(XObj (Lst forms) i t) ->
pure (ctx, Right (XObj (Lst (map toSymbols forms)) i t))
mdl@(XObj (Mod e) _ _) ->
if bol
then getMod
else case lookupInEnv (SymPath [] (fromMaybe "" (envModuleName e))) tyEnv of
Just (_, Binder _ (XObj (Lst forms) i t)) ->
pure (ctx, Right (XObj (Lst (map toSymbols forms)) i t))
Just (_, Binder _ xobj') ->
pure (ctx, Right (toSymbols xobj'))
Nothing ->
getMod
where
getMod =
case (toSymbols mdl) of
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 _) _ _))) =
(c, Right (XObj (Lst (xs ++ [y])) i t))
combine _ (c, (Left err)) =
(c, Left err)
combine (c, Left err) _ =
(c, Left err)
_ ->
pure $ evalError ctx ("can't get an s-expression for: " ++ pretty xobj ++ " is it a bound symbol or literal s-expression?") (Just dummyInfo)
toSymbols :: XObj -> XObj
toSymbols (XObj (Mod e) i t) =
(XObj (Lst [XObj (Sym (SymPath [] "defmodule") Symbol) i t,
XObj (Sym (SymPath [] (fromMaybe "" (envModuleName e))) Symbol) i t]) i t)
( XObj
( Lst
[ XObj (Sym (SymPath [] "defmodule") Symbol) i t,
XObj (Sym (SymPath [] (fromMaybe "" (envModuleName e))) Symbol) i t
]
)
i
t
)
toSymbols (XObj (Defn _) i t) = (XObj (Sym (SymPath [] "defn") Symbol) i t)
toSymbols (XObj Def i t) = (XObj (Sym (SymPath [] "def") Symbol) i t)
toSymbols (XObj (Deftype _) i t) = (XObj (Sym (SymPath [] "deftype") Symbol) i t)

2133
src/Concretize.hs
View File

File diff suppressed because it is too large Load Diff

290
src/Constraints.hs
View File

@ -1,64 +1,68 @@
module Constraints (solve,
Constraint(..),
ConstraintOrder(..),
UnificationFailure(..),
recursiveLookup,
debugSolveOne, -- exported to avoid warning about unused function (should be another way...)
debugResolveFully -- exported to avoid warning about unused function
) where
module Constraints
( solve,
Constraint (..),
ConstraintOrder (..),
UnificationFailure (..),
recursiveLookup,
debugSolveOne, -- exported to avoid warning about unused function (should be another way...)
debugResolveFully, -- exported to avoid warning about unused function
)
where
import Control.Monad
import qualified Data.Map as Map
import qualified Data.Set as Set
import Control.Monad
import Debug.Trace
import Obj
import Types
data ConstraintOrder = OrdNo
| OrdFunc
| OrdStruct
| OrdPtr
| OrdRef
| OrdDeref
| OrdFuncAppRet
| OrdArrHead
| OrdArg
| OrdCapture
| OrdDefnBody
| OrdDefExpr
| OrdLetBind
| OrdLetBody
| OrdIfCondition
| OrdIfReturn
| OrdIfWhole
| OrdWhileBody
| OrdWhileCondition
| OrdDoReturn
| OrdDoStatement
| OrdSetBang
| OrdThe
| OrdAnd
| OrdOr
| OrdFuncAppVarTy
| OrdFuncAppArg
| OrdArrBetween
| OrdMultiSym
| OrdInterfaceSym
| OrdInterfaceImpl
| OrdSignatureAnnotation
deriving (Show, Ord, Eq)
data ConstraintOrder
= OrdNo
| OrdFunc
| OrdStruct
| OrdPtr
| OrdRef
| OrdDeref
| OrdFuncAppRet
| OrdArrHead
| OrdArg
| OrdCapture
| OrdDefnBody
| OrdDefExpr
| OrdLetBind
| OrdLetBody
| OrdIfCondition
| OrdIfReturn
| OrdIfWhole
| OrdWhileBody
| OrdWhileCondition
| OrdDoReturn
| OrdDoStatement
| OrdSetBang
| OrdThe
| OrdAnd
| OrdOr
| OrdFuncAppVarTy
| OrdFuncAppArg
| OrdArrBetween
| OrdMultiSym
| OrdInterfaceSym
| OrdInterfaceImpl
| OrdSignatureAnnotation
deriving (Show, Ord, Eq)
data Constraint = Constraint Ty Ty XObj XObj XObj ConstraintOrder deriving Eq
data Constraint = Constraint Ty Ty XObj XObj XObj ConstraintOrder deriving (Eq)
instance Ord Constraint where
compare (Constraint _ _ _ _ _ a) (Constraint _ _ _ _ _ b) = compare a b
data UnificationFailure = UnificationFailure { unificationFailure ::Constraint
, unificationMappings :: TypeMappings
}
| Holes [(String, Ty)]
deriving (Eq, Show)
data UnificationFailure
= UnificationFailure
{ unificationFailure :: Constraint,
unificationMappings :: TypeMappings
}
| Holes [(String, Ty)]
deriving (Eq, Show)
instance Show Constraint where
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
@ -66,26 +70,29 @@ instance Show Constraint where
-- Finds the symbol with the "lowest name" (first in alphabetical order)
recursiveLookup :: TypeMappings -> String -> Maybe Ty
recursiveLookup mappings name = innerLookup name []
where innerLookup :: String -> [Ty] -> Maybe Ty
innerLookup k visited =
case Map.lookup k mappings of
Just exists -> case exists of
VarTy v -> if exists `elem` visited
then stop
else innerLookup v (exists : visited)
actualType -> Just actualType
where
stop = Just (minimum (exists : visited))
Nothing -> Nothing
where
innerLookup :: String -> [Ty] -> Maybe Ty
innerLookup k visited =
case Map.lookup k mappings of
Just exists -> case exists of
VarTy v ->
if exists `elem` visited
then stop
else innerLookup v (exists : visited)
actualType -> Just actualType
where
stop = Just (minimum (exists : visited))
Nothing -> Nothing
-- | This is the entry-point function that takes a list of constraints
-- (for example [t0 == Int, t1 == t0, t1 == t2])
-- and creates a dictionary of mappings for the type variables
-- (for example t0 => Int, t1 => Int, t2 => Int).
solve :: [Constraint] -> Either UnificationFailure TypeMappings
solve constraints = do naiveMappings <- foldM solveOne Map.empty constraints
fullyResolved <- foldM resolveFully naiveMappings (map fst (Map.toList naiveMappings))
checkForHoles fullyResolved
solve constraints = do
naiveMappings <- foldM solveOne Map.empty constraints
fullyResolved <- foldM resolveFully naiveMappings (map fst (Map.toList naiveMappings))
checkForHoles fullyResolved
checkForHoles :: TypeMappings -> Either UnificationFailure TypeMappings
checkForHoles mappings = case filter isTypeHole (Map.toList mappings) of
@ -100,78 +107,80 @@ solveOne :: TypeMappings -> Constraint -> Either UnificationFailure TypeMappings
solveOne = solveOneInternal
debugSolveOne :: TypeMappings -> Constraint -> Either UnificationFailure TypeMappings
debugSolveOne mappings constraint = let m' = solveOneInternal mappings constraint
in trace ("" ++ show constraint ++ ", MAPPINGS: " ++ show m')
m'
debugSolveOne mappings constraint =
let m' = solveOneInternal mappings constraint
in trace
("" ++ show constraint ++ ", MAPPINGS: " ++ show m')
m'
solveOneInternal :: TypeMappings -> Constraint -> Either UnificationFailure TypeMappings
solveOneInternal mappings constraint =
case constraint of --trace ("SOLVE " ++ show constraint) constraint of
-- Two type variables
-- Two type variables
Constraint aTy@(VarTy aName) bTy@(VarTy bName) _ _ _ _ ->
if aTy == bTy
then Right mappings
else do m' <- checkForConflict mappings constraint aName bTy
checkForConflict m' constraint bName aTy
then Right mappings
else do
m' <- checkForConflict mappings constraint aName bTy
checkForConflict m' constraint bName aTy
-- One type variable
Constraint (VarTy aName) bTy _ _ _ _ -> checkForConflict mappings constraint aName bTy
Constraint aTy (VarTy bName) _ _ _ _ -> checkForConflict mappings constraint bName aTy
Constraint (VarTy aName) bTy _ _ _ _ -> checkForConflict mappings constraint aName bTy
Constraint aTy (VarTy bName) _ _ _ _ -> checkForConflict mappings constraint bName aTy
-- Struct types
Constraint (StructTy nameA varsA) (StructTy nameB varsB) _ _ _ _ ->
let (Constraint _ _ i1 i2 ctx ord) = constraint
in case solveOneInternal mappings (Constraint nameA nameB i1 i2 ctx ord) of
Left err -> Left err
Right ok -> foldM (\m (aa, bb) -> solveOneInternal m (Constraint aa bb i1 i2 ctx ord)) ok (zip varsA varsB)
in case solveOneInternal mappings (Constraint nameA nameB i1 i2 ctx ord) of
Left err -> Left err
Right ok -> foldM (\m (aa, bb) -> solveOneInternal m (Constraint aa bb i1 i2 ctx ord)) ok (zip varsA varsB)
-- Func types
Constraint (FuncTy argsA retA ltA) (FuncTy argsB retB ltB) _ _ _ _ ->
if length argsA == length argsB
then let (Constraint _ _ i1 i2 ctx ord) = constraint
res = foldM (\m (aa, bb) -> solveOneInternal m (Constraint aa bb i1 i2 ctx ord)) mappings (zip (retA : argsA)
(retB : argsB))
in case res of
Right ok -> solveOneInternal ok (Constraint ltA ltB i1 i2 ctx ord)
Left err -> Left err
else Left (UnificationFailure constraint mappings)
then
let (Constraint _ _ i1 i2 ctx ord) = constraint
res =
foldM
(\m (aa, bb) -> solveOneInternal m (Constraint aa bb i1 i2 ctx ord))
mappings
( zip
(retA : argsA)
(retB : argsB)
)
in case res of
Right ok -> solveOneInternal ok (Constraint ltA ltB i1 i2 ctx ord)
Left err -> Left err
else Left (UnificationFailure constraint mappings)
-- Pointer types
Constraint (PointerTy a) (PointerTy b) _ _ _ _ ->
let (Constraint _ _ i1 i2 ctx ord) = constraint
in solveOneInternal mappings (Constraint a b i1 i2 ctx ord)
in solveOneInternal mappings (Constraint a b i1 i2 ctx ord)
-- Ref types
-- TODO: This messes up the error message since the constraint is between non-reffed types so the refs don't show in the error message!!!
Constraint (RefTy a ltA) (RefTy b ltB) _ _ _ _ ->
let (Constraint _ _ i1 i2 ctx ord) = constraint
in case solveOneInternal mappings (Constraint a b i1 i2 ctx ord) of
in case solveOneInternal mappings (Constraint a b i1 i2 ctx ord) of
Left err -> Left err
Right ok -> solveOneInternal ok (Constraint ltA ltB i1 i2 ctx ord)
-- As a special case, allow Refs to stand for higher-order polymorphic
-- structs (f a b) ~ (Ref a b)
Constraint (StructTy v@(VarTy _) args) (RefTy b ltB) _ _ _ _ ->
let (Constraint _ _ i1 i2 ctx ord) = constraint
in case solveOneInternal mappings (Constraint v (RefTy b ltB) i1 i2 ctx ord) of
in case solveOneInternal mappings (Constraint v (RefTy b ltB) i1 i2 ctx ord) of
Left err -> Left err
Right ok -> foldM (\m (aa, bb) -> solveOneInternal m (Constraint aa bb i1 i2 ctx ord)) ok (zip args [b, ltB])
-- TODO: The reverse argument order is necessary here since interface code
-- uses the opposite order of most other solving code (abstract, concrete
-- vs. concrete, abstract)--we should bring the interface code into
-- compliance with this to obviate this stanza
Constraint (RefTy b ltB) (StructTy v@(VarTy _) args) _ _ _ _ ->
let (Constraint _ _ i1 i2 ctx ord) = constraint
in case solveOneInternal mappings (Constraint v (RefTy b ltB) i1 i2 ctx ord) of
in case solveOneInternal mappings (Constraint v (RefTy b ltB) i1 i2 ctx ord) of
Left err -> Left err
Right ok -> foldM (\m (aa, bb) -> solveOneInternal m (Constraint aa bb i1 i2 ctx ord)) ok (zip args [b, ltB])
-- Else
Constraint aTy bTy _ _ _ _ ->
if aTy == bTy
then Right mappings
else Left (UnificationFailure constraint mappings)
then Right mappings
else Left (UnificationFailure constraint mappings)
mkConstraint :: ConstraintOrder -> XObj -> XObj -> XObj -> Ty -> Ty -> Constraint
mkConstraint order xobj1 xobj2 ctx t1 t2 = Constraint t1 t2 xobj1 xobj2 ctx order
@ -185,14 +194,14 @@ checkForConflict mappings constraint@(Constraint _ _ _ _ _ OrdInterfaceImpl) nam
checkConflictInternal mappings constraint name otherTy
checkForConflict mappings constraint name otherTy =
if doesTypeContainTyVarWithName name otherTy
then Left (UnificationFailure constraint mappings)
else checkConflictInternal mappings constraint name otherTy
then Left (UnificationFailure constraint mappings)
else checkConflictInternal mappings constraint name otherTy
checkConflictInternal :: TypeMappings -> Constraint -> String -> Ty -> Either UnificationFailure TypeMappings
checkConflictInternal mappings constraint name otherTy =
let (Constraint _ _ xobj1 xobj2 ctx _) = constraint
let (Constraint _ _ xobj1 xobj2 ctx _) = constraint
found = recursiveLookup mappings name
in case found of --trace ("CHECK CONFLICT " ++ show constraint ++ " with name " ++ name ++ ", otherTy: " ++ show otherTy ++ ", found: " ++ show found) found of
in case found of --trace ("CHECK CONFLICT " ++ show constraint ++ " with name " ++ name ++ ", otherTy: " ++ show otherTy ++ ", found: " ++ show found) found of
Just (VarTy _) -> ok
Just (StructTy (VarTy _) structTyVars) ->
case otherTy of
@ -209,10 +218,11 @@ checkConflictInternal mappings constraint name otherTy =
Just (FuncTy argTys retTy lifetimeTy) ->
case otherTy of
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 _ -> solveOneInternal m (mkConstraint OrdFunc xobj1 xobj2 ctx lifetimeTy otherLifetimeTy)
Left err -> Left err
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 _ -> solveOneInternal m (mkConstraint OrdFunc xobj1 xobj2 ctx lifetimeTy otherLifetimeTy)
Left err -> Left err
VarTy _ -> Right mappings
_ -> Left (UnificationFailure constraint mappings)
Just (PointerTy innerTy) ->
@ -229,46 +239,48 @@ checkConflictInternal mappings constraint name otherTy =
VarTy _ -> Right mappings
_ -> Left (UnificationFailure constraint mappings)
Just foundNonVar -> case otherTy of
(VarTy v) -> case recursiveLookup mappings v of
Just (VarTy _) -> Right mappings
Just otherNonVar -> if foundNonVar == otherNonVar
then Right mappings
else Left (UnificationFailure constraint mappings)
Nothing -> Right mappings
_ -> if otherTy == foundNonVar
then ok
else Left (UnificationFailure constraint mappings)
(VarTy v) -> case recursiveLookup mappings v of
Just (VarTy _) -> Right mappings
Just otherNonVar ->
if foundNonVar == otherNonVar
then Right mappings
else Left (UnificationFailure constraint mappings)
Nothing -> Right mappings
_ ->
if otherTy == foundNonVar
then ok
else Left (UnificationFailure constraint mappings)
-- Not found, no risk for conflict:
Nothing -> ok
where
ok = Right (Map.insert name otherTy mappings)
where
ok = Right (Map.insert name otherTy mappings)
debugResolveFully :: TypeMappings -> String -> Either UnificationFailure TypeMappings
debugResolveFully mappings var = trace ("Mappings: " ++ show mappings ++ ", will resolve " ++ show var) (resolveFully mappings var)
resolveFully :: TypeMappings -> String -> Either UnificationFailure TypeMappings
resolveFully mappings varName = Right (Map.insert varName (fullResolve (VarTy varName)) mappings)
where fullResolve :: Ty -> Ty
fullResolve x@(VarTy var) =
case recursiveLookup mappings var of
Just (StructTy name varTys) -> StructTy name (map (fullLookup Set.empty) varTys)
Just (FuncTy argTys retTy ltTy) -> FuncTy (map (fullLookup Set.empty) argTys) (fullLookup Set.empty retTy) (fullLookup Set.empty ltTy)
Just found -> found
Nothing -> x -- still not found, must be a generic variable
fullResolve x = x
fullLookup :: Set.Set Ty -> Ty -> Ty
fullLookup visited vv@(VarTy v) =
case recursiveLookup mappings v of
Just found -> if found == vv || Set.member found visited
then found
else fullLookup (Set.insert found visited) found
Nothing -> vv-- compilerError ("In full lookup: Can't find " ++ v ++ " in mappings: " ++ show mappings)
fullLookup visited structTy@(StructTy name vs) =
let newVisited = Set.insert structTy visited
in StructTy name (map (fullLookup newVisited) vs)
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 _ x = x
where
fullResolve :: Ty -> Ty
fullResolve x@(VarTy var) =
case recursiveLookup mappings var of
Just (StructTy name varTys) -> StructTy name (map (fullLookup Set.empty) varTys)
Just (FuncTy argTys retTy ltTy) -> FuncTy (map (fullLookup Set.empty) argTys) (fullLookup Set.empty retTy) (fullLookup Set.empty ltTy)
Just found -> found
Nothing -> x -- still not found, must be a generic variable
fullResolve x = x
fullLookup :: Set.Set Ty -> Ty -> Ty
fullLookup visited vv@(VarTy v) =
case recursiveLookup mappings v of
Just found ->
if found == vv || Set.member found visited
then found
else fullLookup (Set.insert found visited) found
Nothing -> vv -- compilerError ("In full lookup: Can't find " ++ v ++ " in mappings: " ++ show mappings)
fullLookup visited structTy@(StructTy name vs) =
let newVisited = Set.insert structTy visited
in StructTy name (map (fullLookup newVisited) vs)
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 _ x = x

664
src/Deftype.hs
View File

@ -1,25 +1,30 @@
{-# LANGUAGE MultiWayIf #-}
module Deftype (moduleForDeftype, bindingsForRegisteredType, memberArg) where
module Deftype
( moduleForDeftype,
bindingsForRegisteredType,
memberArg,
)
where
import Concretize
import qualified Data.Map as Map
import Data.Maybe
import Infer
import Info
import Lookup
import Obj
import StructUtils
import Template
import ToTemplate
import TypeError
import Types
import TypesToC
import Util
import Template
import ToTemplate
import Infer
import Concretize
import Lookup
import StructUtils
import TypeError
import Validate
import Info
{-# ANN module "HLint: ignore Reduce duplication" #-}
-- | This function creates a "Type Module" with the same name as the type being defined.
-- A type module provides a namespace for all the functions that area automatically
-- generated by a deftype.
@ -30,7 +35,8 @@ moduleForDeftype innerEnv typeEnv env pathStrings typeName typeVariables rest i
-- The variable 'insidePath' is the path used for all member functions inside the 'typeModule'.
-- For example (module Vec2 [x Float]) creates bindings like Vec2.create, Vec2.x, etc.
insidePath = pathStrings ++ [typeModuleName]
in do validateMemberCases typeEnv typeVariables rest
in do
validateMemberCases typeEnv typeVariables rest
let structTy = StructTy (ConcreteNameTy typeName) typeVariables
(okMembers, membersDeps) <- templatesForMembers typeEnv env insidePath structTy rest
okInit <- binderForInit insidePath structTy rest
@ -38,7 +44,7 @@ moduleForDeftype innerEnv typeEnv env pathStrings typeName typeVariables rest i
(okPrn, _) <- binderForStrOrPrn typeEnv env insidePath structTy rest "prn"
(okDelete, deleteDeps) <- binderForDelete typeEnv env insidePath structTy rest
(okCopy, copyDeps) <- binderForCopy typeEnv env insidePath structTy rest
let funcs = okInit : okStr : okPrn : okDelete : okCopy : okMembers
let funcs = okInit : okStr : okPrn : okDelete : okCopy : okMembers
moduleEnvWithBindings = addListOfBindings typeModuleEnv funcs
typeModuleXObj = XObj (Mod moduleEnvWithBindings) i (Just ModuleTy)
deps = deleteDeps ++ membersDeps ++ copyDeps ++ strDeps
@ -52,7 +58,8 @@ bindingsForRegisteredType typeEnv env pathStrings typeName rest i existingEnv =
let typeModuleName = typeName
typeModuleEnv = fromMaybe (Env (Map.fromList []) (Just env) (Just typeModuleName) [] ExternalEnv 0) existingEnv
insidePath = pathStrings ++ [typeModuleName]
in do validateMemberCases typeEnv [] rest
in do
validateMemberCases typeEnv [] rest
let structTy = StructTy (ConcreteNameTy typeName) []
(binders, deps) <- templatesForMembers typeEnv env insidePath structTy rest
okInit <- binderForInit insidePath structTy rest
@ -62,13 +69,11 @@ bindingsForRegisteredType typeEnv env pathStrings typeName rest i existingEnv =
typeModuleXObj = XObj (Mod moduleEnvWithBindings) i (Just ModuleTy)
pure (typeModuleName, typeModuleXObj, deps ++ strDeps)
-- | Generate all the templates for ALL the member variables in a deftype declaration.
templatesForMembers :: TypeEnv -> Env -> [String] -> Ty -> [XObj] -> Either TypeError ([(String, Binder)], [XObj])
templatesForMembers typeEnv env insidePath structTy [XObj (Arr membersXobjs) _ _] =
let bindersAndDeps = concatMap (templatesForSingleMember typeEnv env insidePath structTy) (pairwise membersXobjs)
in Right (map fst bindersAndDeps, concatMap snd bindersAndDeps)
in Right (map fst bindersAndDeps, concatMap snd bindersAndDeps)
templatesForMembers _ _ _ _ _ = error "Shouldn't reach this case (invalid type definition)."
-- | Generate the templates for a single member in a deftype declaration.
@ -79,30 +84,34 @@ templatesForSingleMember typeEnv env insidePath p@(StructTy (ConcreteNameTy type
-- Instead, members of type Unit are executed for their side effects and silently omitted
-- from the produced C structs.
UnitTy ->
binders (FuncTy [RefTy p (VarTy "q")] UnitTy StaticLifetimeTy)
(FuncTy [p, t] p StaticLifetimeTy)
(FuncTy [RefTy p (VarTy "q"), t] UnitTy StaticLifetimeTy)
(FuncTy [p, RefTy (FuncTy [] UnitTy (VarTy "fq")) (VarTy "q")] p StaticLifetimeTy)
binders
(FuncTy [RefTy p (VarTy "q")] UnitTy StaticLifetimeTy)
(FuncTy [p, t] p StaticLifetimeTy)
(FuncTy [RefTy p (VarTy "q"), t] UnitTy StaticLifetimeTy)
(FuncTy [p, RefTy (FuncTy [] UnitTy (VarTy "fq")) (VarTy "q")] p StaticLifetimeTy)
_ ->
binders (FuncTy [RefTy p (VarTy "q")] (RefTy t (VarTy "q")) StaticLifetimeTy)
(FuncTy [p, t] p StaticLifetimeTy)
(FuncTy [RefTy p (VarTy "q"), t] UnitTy StaticLifetimeTy)
(FuncTy [p, RefTy (FuncTy [t] t (VarTy "fq")) (VarTy "q")] p StaticLifetimeTy)
where Just t = xobjToTy typeXObj
memberName = getName nameXObj
binders getterSig setterSig mutatorSig updaterSig =
[instanceBinderWithDeps (SymPath insidePath memberName) getterSig (templateGetter (mangle memberName) t) ("gets the `" ++ memberName ++ "` property of a `" ++ typeName ++ "`.")
, if isTypeGeneric t
then (templateGenericSetter insidePath p t memberName, [])
else instanceBinderWithDeps (SymPath insidePath ("set-" ++ memberName)) setterSig (templateSetter typeEnv env (mangle memberName) t) ("sets the `" ++ memberName ++ "` property of a `" ++ typeName ++ "`.")
, if isTypeGeneric t
then (templateGenericMutatingSetter insidePath p t memberName, [])
else instanceBinderWithDeps (SymPath insidePath ("set-" ++ memberName ++ "!")) mutatorSig (templateMutatingSetter typeEnv env (mangle memberName) t) ("sets the `" ++ memberName ++ "` property of a `" ++ typeName ++ "` in place.")
,instanceBinderWithDeps (SymPath insidePath ("update-" ++ memberName))
updaterSig
(templateUpdater (mangle memberName) t)
("updates the `" ++ memberName ++ "` property of a `" ++ typeName ++ "` using a function `f`.")
]
binders
(FuncTy [RefTy p (VarTy "q")] (RefTy t (VarTy "q")) StaticLifetimeTy)
(FuncTy [p, t] p StaticLifetimeTy)
(FuncTy [RefTy p (VarTy "q"), t] UnitTy StaticLifetimeTy)
(FuncTy [p, RefTy (FuncTy [t] t (VarTy "fq")) (VarTy "q")] p StaticLifetimeTy)
where
Just t = xobjToTy typeXObj
memberName = getName nameXObj
binders getterSig setterSig mutatorSig updaterSig =
[ instanceBinderWithDeps (SymPath insidePath memberName) getterSig (templateGetter (mangle memberName) t) ("gets the `" ++ memberName ++ "` property of a `" ++ typeName ++ "`."),
if isTypeGeneric t
then (templateGenericSetter insidePath p t memberName, [])
else instanceBinderWithDeps (SymPath insidePath ("set-" ++ memberName)) setterSig (templateSetter typeEnv env (mangle memberName) t) ("sets the `" ++ memberName ++ "` property of a `" ++ typeName ++ "`."),
if isTypeGeneric t
then (templateGenericMutatingSetter insidePath p t memberName, [])
else instanceBinderWithDeps (SymPath insidePath ("set-" ++ memberName ++ "!")) mutatorSig (templateMutatingSetter typeEnv env (mangle memberName) t) ("sets the `" ++ memberName ++ "` property of a `" ++ typeName ++ "` in place."),
instanceBinderWithDeps
(SymPath insidePath ("update-" ++ memberName))
updaterSig
(templateUpdater (mangle memberName) t)
("updates the `" ++ memberName ++ "` property of a `" ++ typeName ++ "` using a function `f`.")
]
-- | The template for getters of a deftype.
templateGetter :: String -> Ty -> Template
@ -117,14 +126,16 @@ templateGetter member memberTy =
Template
(FuncTy [RefTy (VarTy "p") (VarTy "q")] (VarTy "t") StaticLifetimeTy)
(const (toTemplate "$t $NAME($(Ref p) p)"))
(\(FuncTy [_] retTy _) ->
case retTy of
(RefTy UnitTy _) -> toTemplate " $DECL { void* ptr = NULL; return ptr; }\n"
_ -> let fixForVoidStarMembers =
( \(FuncTy [_] retTy _) ->
case retTy of
(RefTy UnitTy _) -> toTemplate " $DECL { void* ptr = NULL; return ptr; }\n"
_ ->
let fixForVoidStarMembers =
if isFunctionType memberTy && not (isTypeGeneric memberTy)
then "(" ++ tyToCLambdaFix (RefTy memberTy (VarTy "q")) ++ ")"
else ""
in toTemplate ("$DECL { return " ++ fixForVoidStarMembers ++ "(&(p->" ++ member ++ ")); }\n"))
then "(" ++ tyToCLambdaFix (RefTy memberTy (VarTy "q")) ++ ")"
else ""
in toTemplate ("$DECL { return " ++ fixForVoidStarMembers ++ "(&(p->" ++ member ++ ")); }\n")
)
(const [])
-- | The template for setters of a concrete deftype.
@ -138,47 +149,64 @@ templateSetter _ _ _ UnitTy =
(const [])
templateSetter typeEnv env memberName memberTy =
let callToDelete = memberDeletion typeEnv env (memberName, memberTy)
in
Template
(FuncTy [VarTy "p", VarTy "t"] (VarTy "p") StaticLifetimeTy)
(const (toTemplate "$p $NAME($p p, $t newValue)"))
(const (toTemplate (unlines ["$DECL {"
,callToDelete
," p." ++ memberName ++ " = newValue;"
," return p;"
,"}\n"])))
(\_ -> if | isManaged typeEnv memberTy -> depsOfPolymorphicFunction typeEnv env [] "delete" (typesDeleterFunctionType memberTy)
| isFunctionType memberTy -> [defineFunctionTypeAlias memberTy]
| otherwise -> [])
in Template
(FuncTy [VarTy "p", VarTy "t"] (VarTy "p") StaticLifetimeTy)
(const (toTemplate "$p $NAME($p p, $t newValue)"))
( const
( toTemplate
( unlines
[ "$DECL {",
callToDelete,
" p." ++ memberName ++ " = newValue;",
" return p;",
"}\n"
]
)
)
)
( \_ ->
if | isManaged typeEnv memberTy -> depsOfPolymorphicFunction typeEnv env [] "delete" (typesDeleterFunctionType memberTy)
| isFunctionType memberTy -> [defineFunctionTypeAlias memberTy]
| otherwise -> []
)
-- | The template for setters of a generic deftype.
templateGenericSetter :: [String] -> Ty -> Ty -> String -> (String, Binder)
templateGenericSetter pathStrings originalStructTy@(StructTy (ConcreteNameTy typeName) _) membTy memberName =
defineTypeParameterizedTemplate templateCreator path (FuncTy [originalStructTy, membTy] originalStructTy StaticLifetimeTy) docs
where path = SymPath pathStrings ("set-" ++ memberName)
t = FuncTy [VarTy "p", VarTy "t"] (VarTy "p") StaticLifetimeTy
docs = "sets the `" ++ memberName ++ "` property of a `" ++ typeName ++ "`."
templateCreator = TemplateCreator $
\typeEnv env ->
Template
t
(\(FuncTy [_, memberTy] _ _) ->
where
path = SymPath pathStrings ("set-" ++ memberName)
t = FuncTy [VarTy "p", VarTy "t"] (VarTy "p") StaticLifetimeTy
docs = "sets the `" ++ memberName ++ "` property of a `" ++ typeName ++ "`."
templateCreator = TemplateCreator $
\typeEnv env ->
Template
t
( \(FuncTy [_, memberTy] _ _) ->
case memberTy of
UnitTy -> (toTemplate "$p $NAME($p p)")
_ -> (toTemplate "$p $NAME($p p, $t newValue)"))
(\(FuncTy [_, memberTy] _ _) ->
let callToDelete = memberDeletion typeEnv env (memberName, memberTy)
in case memberTy of
UnitTy -> toTemplate "$DECL { return p; }\n"
_ -> toTemplate (unlines ["$DECL {"
,callToDelete
," p." ++ memberName ++ " = newValue;"
," return p;"
,"}\n"]))
(\(FuncTy [_, memberTy] _ _) ->
if isManaged typeEnv memberTy
then depsOfPolymorphicFunction typeEnv env [] "delete" (typesDeleterFunctionType memberTy)
else [])
_ -> (toTemplate "$p $NAME($p p, $t newValue)")
)
( \(FuncTy [_, memberTy] _ _) ->
let callToDelete = memberDeletion typeEnv env (memberName, memberTy)
in case memberTy of
UnitTy -> toTemplate "$DECL { return p; }\n"
_ ->
toTemplate
( unlines
[ "$DECL {",
callToDelete,
" p." ++ memberName ++ " = newValue;",
" return p;",
"}\n"
]
)
)
( \(FuncTy [_, memberTy] _ _) ->
if isManaged typeEnv memberTy
then depsOfPolymorphicFunction typeEnv env [] "delete" (typesDeleterFunctionType memberTy)
else []
)
-- | The template for mutating setters of a deftype.
templateMutatingSetter :: TypeEnv -> Env -> String -> Ty -> Template
@ -191,42 +219,58 @@ templateMutatingSetter _ _ _ UnitTy =
(const [])
templateMutatingSetter typeEnv env memberName memberTy =
let callToDelete = memberRefDeletion typeEnv env (memberName, memberTy)
in Template
(FuncTy [RefTy (VarTy "p") (VarTy "q"), VarTy "t"] UnitTy StaticLifetimeTy)
(const (toTemplate "void $NAME($p* pRef, $t newValue)"))
(const (toTemplate (unlines ["$DECL {"
,callToDelete
," pRef->" ++ memberName ++ " = newValue;"
,"}\n"])))
(const [])
in Template
(FuncTy [RefTy (VarTy "p") (VarTy "q"), VarTy "t"] UnitTy StaticLifetimeTy)
(const (toTemplate "void $NAME($p* pRef, $t newValue)"))
( const
( toTemplate
( unlines
[ "$DECL {",
callToDelete,
" pRef->" ++ memberName ++ " = newValue;",
"}\n"
]
)
)
)
(const [])
-- | The template for mutating setters of a generic deftype.
templateGenericMutatingSetter :: [String] -> Ty -> Ty -> String -> (String, Binder)
templateGenericMutatingSetter pathStrings originalStructTy@(StructTy (ConcreteNameTy typeName) _) membTy memberName =
defineTypeParameterizedTemplate templateCreator path (FuncTy [(RefTy originalStructTy (VarTy "q")), membTy] UnitTy StaticLifetimeTy) docs
where path = SymPath pathStrings ("set-" ++ memberName ++ "!")
t = FuncTy [RefTy (VarTy "p") (VarTy "q"), VarTy "t"] UnitTy StaticLifetimeTy
docs = "sets the `" ++ memberName ++ "` property of a `" ++ typeName ++ "` in place."
templateCreator = TemplateCreator $
\typeEnv env ->
Template
t
(\(FuncTy [_, memberTy] _ _) ->
where
path = SymPath pathStrings ("set-" ++ memberName ++ "!")
t = FuncTy [RefTy (VarTy "p") (VarTy "q"), VarTy "t"] UnitTy StaticLifetimeTy
docs = "sets the `" ++ memberName ++ "` property of a `" ++ typeName ++ "` in place."
templateCreator = TemplateCreator $
\typeEnv env ->
Template
t
( \(FuncTy [_, memberTy] _ _) ->
case memberTy of
UnitTy -> (toTemplate "void $NAME($p* pRef)")
_ -> (toTemplate "void $NAME($p* pRef, $t newValue)"))
(\(FuncTy [_, memberTy] _ _) ->
let callToDelete = memberRefDeletion typeEnv env (memberName, memberTy)
in case memberTy of
UnitTy -> (toTemplate "$DECL { return; }\n")
_ -> toTemplate (unlines ["$DECL {"
,callToDelete
," pRef->" ++ memberName ++ " = newValue;"
,"}\n"]))
(\(FuncTy [_, memberTy] _ _) ->
if isManaged typeEnv memberTy
then depsOfPolymorphicFunction typeEnv env [] "delete" (typesDeleterFunctionType memberTy)
else [])
_ -> (toTemplate "void $NAME($p* pRef, $t newValue)")
)
( \(FuncTy [_, memberTy] _ _) ->
let callToDelete = memberRefDeletion typeEnv env (memberName, memberTy)
in case memberTy of
UnitTy -> (toTemplate "$DECL { return; }\n")
_ ->
toTemplate
( unlines
[ "$DECL {",
callToDelete,
" pRef->" ++ memberName ++ " = newValue;",
"}\n"
]
)
)
( \(FuncTy [_, memberTy] _ _) ->
if isManaged typeEnv memberTy
then depsOfPolymorphicFunction typeEnv env [] "delete" (typesDeleterFunctionType memberTy)
else []
)
-- | The template for updater functions of a deftype.
-- | (allows changing a variable by passing an transformation function).
@ -235,32 +279,44 @@ 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)
-- Execution of the action passed as an argument is handled in Emit.hs.
-- Execution of the action passed as an argument is handled in Emit.hs.
(const (toTemplate ("$DECL { " ++ templateCodeForCallingLambda "(*updater)" (FuncTy [] UnitTy (VarTy "fq")) [] ++ "; return p;}\n")))
(\(FuncTy [_, RefTy t@(FuncTy fArgTys fRetTy _) _] _ _) ->
[defineFunctionTypeAlias t, defineFunctionTypeAlias (FuncTy (lambdaEnvTy : fArgTys) fRetTy StaticLifetimeTy)])
( \(FuncTy [_, RefTy t@(FuncTy fArgTys fRetTy _) _] _ _) ->
[defineFunctionTypeAlias t, defineFunctionTypeAlias (FuncTy (lambdaEnvTy : fArgTys) fRetTy StaticLifetimeTy)]
)
templateUpdater member _ =
Template
(FuncTy [VarTy "p", RefTy (FuncTy [VarTy "t"] (VarTy "t") (VarTy "fq")) (VarTy "q")] (VarTy "p") StaticLifetimeTy)
(const (toTemplate "$p $NAME($p p, Lambda *updater)")) -- "Lambda" used to be: $(Fn [t] t)
(const (toTemplate (unlines ["$DECL {"
," p." ++ member ++ " = " ++ templateCodeForCallingLambda "(*updater)" (FuncTy [VarTy "t"] (VarTy "t") (VarTy "fq")) ["p." ++ member] ++ ";"
," return p;"
,"}\n"])))
(\(FuncTy [_, RefTy t@(FuncTy fArgTys fRetTy _) _] _ _) ->
if isTypeGeneric fRetTy
then []
else [defineFunctionTypeAlias t, defineFunctionTypeAlias (FuncTy (lambdaEnvTy : fArgTys) fRetTy StaticLifetimeTy)])
( const
( toTemplate
( unlines
[ "$DECL {",
" p." ++ member ++ " = " ++ templateCodeForCallingLambda "(*updater)" (FuncTy [VarTy "t"] (VarTy "t") (VarTy "fq")) ["p." ++ member] ++ ";",
" return p;",
"}\n"
]
)
)
)
( \(FuncTy [_, RefTy t@(FuncTy fArgTys fRetTy _) _] _ _) ->
if isTypeGeneric fRetTy
then []
else [defineFunctionTypeAlias t, defineFunctionTypeAlias (FuncTy (lambdaEnvTy : fArgTys) fRetTy StaticLifetimeTy)]
)
-- | Helper function to create the binder for the 'init' template.
binderForInit :: [String] -> Ty -> [XObj] -> Either TypeError (String, Binder)
binderForInit insidePath structTy@(StructTy (ConcreteNameTy typeName) _) [XObj (Arr membersXObjs) _ _] =
if isTypeGeneric structTy
then Right (genericInit StackAlloc insidePath structTy membersXObjs)
else Right $ instanceBinder (SymPath insidePath "init")
(FuncTy (initArgListTypes membersXObjs) structTy StaticLifetimeTy)
(concreteInit StackAlloc structTy membersXObjs)
("creates a `" ++ typeName ++ "`.")
then Right (genericInit StackAlloc insidePath structTy membersXObjs)
else
Right $
instanceBinder
(SymPath insidePath "init")
(FuncTy (initArgListTypes membersXObjs) structTy StaticLifetimeTy)
(concreteInit StackAlloc structTy membersXObjs)
("creates a `" ++ typeName ++ "`.")
-- | Generate a list of types from a deftype declaration.
initArgListTypes :: [XObj] -> [Ty]
@ -272,63 +328,74 @@ concreteInit :: AllocationMode -> Ty -> [XObj] -> Template
concreteInit allocationMode originalStructTy@(StructTy (ConcreteNameTy typeName) _) membersXObjs =
Template
(FuncTy (map snd (memberXObjsToPairs membersXObjs)) (VarTy "p") StaticLifetimeTy)
(\(FuncTy _ concreteStructTy _) ->
let mappings = unifySignatures originalStructTy concreteStructTy
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
memberPairs = memberXObjsToPairs correctedMembers
in (toTemplate $ "$p $NAME(" ++ joinWithComma (map memberArg (unitless memberPairs)) ++ ")"))
(\(FuncTy _ concreteStructTy _) ->
let mappings = unifySignatures originalStructTy concreteStructTy
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
in (tokensForInit allocationMode typeName correctedMembers))
(\FuncTy{} -> [])
where unitless = remove (isUnit . snd)
( \(FuncTy _ concreteStructTy _) ->
let mappings = unifySignatures originalStructTy concreteStructTy
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
memberPairs = memberXObjsToPairs correctedMembers
in (toTemplate $ "$p $NAME(" ++ joinWithComma (map memberArg (unitless memberPairs)) ++ ")")
)
( \(FuncTy _ concreteStructTy _) ->
let mappings = unifySignatures originalStructTy concreteStructTy
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
in (tokensForInit allocationMode typeName correctedMembers)
)
(\FuncTy {} -> [])
where
unitless = remove (isUnit . snd)
-- | The template for the 'init' and 'new' functions for a generic deftype.
genericInit :: AllocationMode -> [String] -> Ty -> [XObj] -> (String, Binder)
genericInit allocationMode pathStrings originalStructTy@(StructTy (ConcreteNameTy typeName) _) membersXObjs =
defineTypeParameterizedTemplate templateCreator path t docs
where path = SymPath pathStrings "init"
t = FuncTy (map snd (memberXObjsToPairs membersXObjs)) originalStructTy StaticLifetimeTy
docs = "creates a `" ++ typeName ++ "`."
templateCreator = TemplateCreator $
\typeEnv _ ->
Template
(FuncTy (map snd (memberXObjsToPairs membersXObjs)) (VarTy "p") StaticLifetimeTy)
(\(FuncTy _ concreteStructTy _) ->
let mappings = unifySignatures originalStructTy concreteStructTy
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
memberPairs = memberXObjsToPairs correctedMembers
in (toTemplate $ "$p $NAME(" ++ joinWithComma (map memberArg (remove (isUnit . snd) memberPairs)) ++ ")"))
(\(FuncTy _ concreteStructTy _) ->
where
path = SymPath pathStrings "init"
t = FuncTy (map snd (memberXObjsToPairs membersXObjs)) originalStructTy StaticLifetimeTy
docs = "creates a `" ++ typeName ++ "`."
templateCreator = TemplateCreator $
\typeEnv _ ->
Template
(FuncTy (map snd (memberXObjsToPairs membersXObjs)) (VarTy "p") StaticLifetimeTy)
( \(FuncTy _ concreteStructTy _) ->
let mappings = unifySignatures originalStructTy concreteStructTy
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
in (tokensForInit allocationMode typeName correctedMembers))
(\(FuncTy _ concreteStructTy _) ->
case concretizeType typeEnv concreteStructTy of
Left err -> error (show err ++ ". This error should not crash the compiler - change return type to Either here.")
Right ok -> ok
)
memberPairs = memberXObjsToPairs correctedMembers
in (toTemplate $ "$p $NAME(" ++ joinWithComma (map memberArg (remove (isUnit . snd) memberPairs)) ++ ")")
)
( \(FuncTy _ concreteStructTy _) ->
let mappings = unifySignatures originalStructTy concreteStructTy
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
in (tokensForInit allocationMode typeName correctedMembers)
)
( \(FuncTy _ concreteStructTy _) ->
case concretizeType typeEnv concreteStructTy of
Left err -> error (show err ++ ". This error should not crash the compiler - change return type to Either here.")
Right ok -> ok
)
tokensForInit :: AllocationMode -> String -> [XObj] -> [Token]
tokensForInit allocationMode typeName membersXObjs =
toTemplate $ unlines [ "$DECL {"
, case allocationMode of
StackAlloc -> case unitless of
-- if this is truly a memberless struct, init it to 0;
-- This can happen, e.g. in cases where *all* members of the struct are of type Unit.
-- Since we do not generate members for Unit types.
[] -> " $p instance = {};"
_ -> " $p instance;"
HeapAlloc -> " $p instance = CARP_MALLOC(sizeof(" ++ typeName ++ "));"
, assignments membersXObjs
, " return instance;"
, "}"]
where assignments [] = " instance.__dummy = 0;"
assignments _ = go $ unitless
where go [] = ""
go xobjs = joinLines $ memberAssignment allocationMode . fst <$> xobjs
unitless = remove (isUnit . snd) (memberXObjsToPairs membersXObjs)
toTemplate $
unlines
[ "$DECL {",
case allocationMode of
StackAlloc -> case unitless of
-- if this is truly a memberless struct, init it to 0;
-- This can happen, e.g. in cases where *all* members of the struct are of type Unit.
-- Since we do not generate members for Unit types.
[] -> " $p instance = {};"
_ -> " $p instance;"
HeapAlloc -> " $p instance = CARP_MALLOC(sizeof(" ++ typeName ++ "));",
assignments membersXObjs,
" return instance;",
"}"
]
where
assignments [] = " instance.__dummy = 0;"
assignments _ = go $ unitless
where
go [] = ""
go xobjs = joinLines $ memberAssignment allocationMode . fst <$> xobjs
unitless = remove (isUnit . snd) (memberXObjsToPairs membersXObjs)
-- | Creates the C code for an arg to the init function.
-- | i.e. "(deftype A [x Int])" will generate "int x" which
@ -350,11 +417,15 @@ templatizeTy t = t
binderForStrOrPrn :: TypeEnv -> Env -> [String] -> Ty -> [XObj] -> String -> Either TypeError ((String, Binder), [XObj])
binderForStrOrPrn typeEnv env insidePath structTy@(StructTy (ConcreteNameTy typeName) _) [XObj (Arr membersXObjs) _ _] strOrPrn =
if isTypeGeneric structTy
then Right (genericStr insidePath structTy membersXObjs strOrPrn, [])
else Right (instanceBinderWithDeps (SymPath insidePath strOrPrn)
(FuncTy [RefTy structTy (VarTy "q")] StringTy StaticLifetimeTy)
(concreteStr typeEnv env structTy (memberXObjsToPairs membersXObjs) strOrPrn)
("converts a `" ++ typeName ++ "` to a string."))
then Right (genericStr insidePath structTy membersXObjs strOrPrn, [])
else
Right
( instanceBinderWithDeps
(SymPath insidePath strOrPrn)
(FuncTy [RefTy structTy (VarTy "q")] StringTy StaticLifetimeTy)
(concreteStr typeEnv env structTy (memberXObjsToPairs membersXObjs) strOrPrn)
("converts a `" ++ typeName ++ "` to a string.")
)
-- | The template for the 'str' function for a concrete deftype.
concreteStr :: TypeEnv -> Env -> Ty -> [(String, Ty)] -> String -> Template
@ -362,142 +433,175 @@ concreteStr typeEnv env concreteStructTy@(StructTy (ConcreteNameTy typeName) _)
Template
(FuncTy [RefTy concreteStructTy (VarTy "q")] StringTy StaticLifetimeTy)
(\(FuncTy [RefTy structTy _] StringTy _) -> toTemplate $ "String $NAME(" ++ tyToCLambdaFix structTy ++ " *p)")
(\(FuncTy [RefTy (StructTy _ _) _] StringTy _) ->
tokensForStr typeEnv env typeName memberPairs concreteStructTy)
(\(FuncTy [RefTy (StructTy _ _) (VarTy "q")] StringTy _) ->
concatMap (depsOfPolymorphicFunction typeEnv env [] "prn" . typesStrFunctionType typeEnv)
(remove isFullyGenericType (map snd memberPairs)))
( \(FuncTy [RefTy (StructTy _ _) _] StringTy _) ->
tokensForStr typeEnv env typeName memberPairs concreteStructTy
)
( \(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) _) membersXObjs strOrPrn =
defineTypeParameterizedTemplate templateCreator path t docs
where path = SymPath pathStrings strOrPrn
t = FuncTy [RefTy originalStructTy (VarTy "q")] StringTy StaticLifetimeTy
docs = "converts a `" ++ typeName ++ "` to a string."
templateCreator = TemplateCreator $
\typeEnv env ->
Template
t
(\(FuncTy [RefTy concreteStructTy _] StringTy _) ->
toTemplate $ "String $NAME(" ++ tyToCLambdaFix concreteStructTy ++ " *p)")
(\(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 _ _) _] StringTy _) ->
let mappings = unifySignatures originalStructTy concreteStructTy
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
memberPairs = memberXObjsToPairs correctedMembers
in concatMap (depsOfPolymorphicFunction typeEnv env [] "prn" . typesStrFunctionType typeEnv)
(remove isFullyGenericType (map snd memberPairs))
++
(if isTypeGeneric concreteStructTy then [] else [defineFunctionTypeAlias ft]))
where
path = SymPath pathStrings strOrPrn
t = FuncTy [RefTy originalStructTy (VarTy "q")] StringTy StaticLifetimeTy
docs = "converts a `" ++ typeName ++ "` to a string."
templateCreator = TemplateCreator $
\typeEnv env ->
Template
t
( \(FuncTy [RefTy concreteStructTy _] StringTy _) ->
toTemplate $ "String $NAME(" ++ tyToCLambdaFix concreteStructTy ++ " *p)"
)
( \(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 _ _) _] StringTy _) ->
let mappings = unifySignatures originalStructTy concreteStructTy
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
memberPairs = memberXObjsToPairs correctedMembers
in concatMap
(depsOfPolymorphicFunction typeEnv env [] "prn" . typesStrFunctionType typeEnv)
(remove isFullyGenericType (map snd memberPairs))
++ (if isTypeGeneric concreteStructTy then [] else [defineFunctionTypeAlias ft])
)
tokensForStr :: TypeEnv -> Env -> String -> [(String, Ty)] -> Ty -> [Token]
tokensForStr typeEnv env typeName memberPairs concreteStructTy =
toTemplate $ unlines [ "$DECL {"
, " // convert members to String here:"
, " String temp = NULL;"
, " int tempsize = 0;"
, " (void)tempsize; // that way we remove the occasional unused warning "
, calculateStructStrSize typeEnv env memberPairs concreteStructTy
, " String buffer = CARP_MALLOC(size);"
, " String bufferPtr = buffer;"
, ""
, " sprintf(bufferPtr, \"(%s \", \"" ++ typeName ++ "\");"
, " bufferPtr += strlen(\"" ++ typeName ++ "\") + 2;\n"
, joinLines (map (memberPrn typeEnv env) memberPairs)
, " bufferPtr--;"
, " sprintf(bufferPtr, \")\");"
, " return buffer;"
, "}"]
tokensForStr typeEnv env typeName memberPairs concreteStructTy =
toTemplate $
unlines
[ "$DECL {",
" // convert members to String here:",
" String temp = NULL;",
" int tempsize = 0;",
" (void)tempsize; // that way we remove the occasional unused warning ",
calculateStructStrSize typeEnv env memberPairs concreteStructTy,
" String buffer = CARP_MALLOC(size);",
" String bufferPtr = buffer;",
"",
" sprintf(bufferPtr, \"(%s \", \"" ++ typeName ++ "\");",
" bufferPtr += strlen(\"" ++ typeName ++ "\") + 2;\n",
joinLines (map (memberPrn typeEnv env) memberPairs),
" bufferPtr--;",
" sprintf(bufferPtr, \")\");",
" return buffer;",
"}"
]
-- | Figure out how big the string needed for the string representation of the struct has to be.
calculateStructStrSize :: TypeEnv -> Env -> [(String, Ty)] -> Ty -> String
calculateStructStrSize typeEnv env members (StructTy (ConcreteNameTy name) _) =
" int size = snprintf(NULL, 0, \"(%s )\", \"" ++ name ++ "\");\n" ++
unlines (map (memberPrnSize typeEnv env) members)
" int size = snprintf(NULL, 0, \"(%s )\", \"" ++ name ++ "\");\n"
++ unlines (map (memberPrnSize typeEnv env) members)
-- | Generate C code for assigning to a member variable.
-- | Needs to know if the instance is a pointer or stack variable.
memberAssignment :: AllocationMode -> String -> String
memberAssignment allocationMode memberName = " instance" ++ sep ++ memberName ++ " = " ++ memberName ++ ";"
where sep = case allocationMode of
StackAlloc -> "."
HeapAlloc -> "->"
where
sep = case allocationMode of
StackAlloc -> "."
HeapAlloc -> "->"
-- | Helper function to create the binder for the 'delete' template.
binderForDelete :: TypeEnv -> Env -> [String] -> Ty -> [XObj] -> Either TypeError ((String, Binder), [XObj])
binderForDelete typeEnv env insidePath structTy@(StructTy (ConcreteNameTy typeName) _) [XObj (Arr membersXObjs) _ _] =
if isTypeGeneric structTy
then Right (genericDelete insidePath structTy membersXObjs, [])
else Right (instanceBinderWithDeps (SymPath insidePath "delete")
(FuncTy [structTy] UnitTy StaticLifetimeTy)
(concreteDelete typeEnv env (memberXObjsToPairs membersXObjs))
("deletes a `" ++ typeName ++"`."))
then Right (genericDelete insidePath structTy membersXObjs, [])
else
Right
( instanceBinderWithDeps
(SymPath insidePath "delete")
(FuncTy [structTy] UnitTy StaticLifetimeTy)
(concreteDelete typeEnv env (memberXObjsToPairs membersXObjs))
("deletes a `" ++ typeName ++ "`.")
)
-- | The template for the 'delete' function of a generic deftype.
genericDelete :: [String] -> Ty -> [XObj] -> (String, Binder)
genericDelete pathStrings originalStructTy@(StructTy (ConcreteNameTy typeName) _) membersXObjs =
defineTypeParameterizedTemplate templateCreator path (FuncTy [originalStructTy] UnitTy StaticLifetimeTy) docs
where path = SymPath pathStrings "delete"
t = FuncTy [VarTy "p"] UnitTy StaticLifetimeTy
docs = "deletes a `" ++ typeName ++ "`. Should usually not be called manually."
templateCreator = TemplateCreator $
\typeEnv env ->
Template
t
(const (toTemplate "void $NAME($p p)"))
(\(FuncTy [concreteStructTy] UnitTy _) ->
let mappings = unifySignatures originalStructTy concreteStructTy
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
memberPairs = memberXObjsToPairs correctedMembers
in (toTemplate $ unlines [ "$DECL {"
, joinLines (map (memberDeletion typeEnv env) memberPairs)
, "}"]))
(\(FuncTy [concreteStructTy] UnitTy _) ->
let mappings = unifySignatures originalStructTy concreteStructTy
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
memberPairs = memberXObjsToPairs correctedMembers
in if isTypeGeneric concreteStructTy
then []
else concatMap (depsOfPolymorphicFunction typeEnv env [] "delete" . typesDeleterFunctionType)
(filter (isManaged typeEnv) (map snd memberPairs)))
where
path = SymPath pathStrings "delete"
t = FuncTy [VarTy "p"] UnitTy StaticLifetimeTy
docs = "deletes a `" ++ typeName ++ "`. Should usually not be called manually."
templateCreator = TemplateCreator $
\typeEnv env ->
Template
t
(const (toTemplate "void $NAME($p p)"))
( \(FuncTy [concreteStructTy] UnitTy _) ->
let mappings = unifySignatures originalStructTy concreteStructTy
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
memberPairs = memberXObjsToPairs correctedMembers
in ( toTemplate $
unlines
[ "$DECL {",
joinLines (map (memberDeletion typeEnv env) memberPairs),
"}"
]
)
)
( \(FuncTy [concreteStructTy] UnitTy _) ->
let mappings = unifySignatures originalStructTy concreteStructTy
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
memberPairs = memberXObjsToPairs correctedMembers
in if isTypeGeneric concreteStructTy
then []
else
concatMap
(depsOfPolymorphicFunction typeEnv env [] "delete" . typesDeleterFunctionType)
(filter (isManaged typeEnv) (map snd memberPairs))
)
-- | Helper function to create the binder for the 'copy' template.
binderForCopy :: TypeEnv -> Env -> [String] -> Ty -> [XObj] -> Either TypeError ((String, Binder), [XObj])
binderForCopy typeEnv env insidePath structTy@(StructTy (ConcreteNameTy typeName) _) [XObj (Arr membersXObjs) _ _] =
if isTypeGeneric structTy
then Right (genericCopy insidePath structTy membersXObjs, [])
else Right (instanceBinderWithDeps (SymPath insidePath "copy")
(FuncTy [RefTy structTy (VarTy "q")] structTy StaticLifetimeTy)
(concreteCopy typeEnv env (memberXObjsToPairs membersXObjs))
("copies a `" ++ typeName ++ "`."))
then Right (genericCopy insidePath structTy membersXObjs, [])
else
Right
( instanceBinderWithDeps
(SymPath insidePath "copy")
(FuncTy [RefTy structTy (VarTy "q")] structTy StaticLifetimeTy)
(concreteCopy typeEnv env (memberXObjsToPairs membersXObjs))
("copies a `" ++ typeName ++ "`.")
)
-- | The template for the 'copy' function of a generic deftype.
genericCopy :: [String] -> Ty -> [XObj] -> (String, Binder)
genericCopy pathStrings originalStructTy@(StructTy (ConcreteNameTy typeName) _) membersXObjs =
defineTypeParameterizedTemplate templateCreator path (FuncTy [RefTy originalStructTy (VarTy "q")] originalStructTy StaticLifetimeTy) docs
where path = SymPath pathStrings "copy"
t = FuncTy [RefTy (VarTy "p") (VarTy "q")] (VarTy "p") StaticLifetimeTy
docs = "copies the `" ++ typeName ++ "`."
templateCreator = TemplateCreator $
\typeEnv env ->
Template
t
(const (toTemplate "$p $NAME($p* pRef)"))
(\(FuncTy [RefTy concreteStructTy _] _ _) ->
let mappings = unifySignatures originalStructTy concreteStructTy
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
memberPairs = memberXObjsToPairs correctedMembers
in tokensForCopy typeEnv env memberPairs)
(\(FuncTy [RefTy concreteStructTy _] _ _) ->
let mappings = unifySignatures originalStructTy concreteStructTy
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
memberPairs = memberXObjsToPairs correctedMembers
in if isTypeGeneric concreteStructTy
then []
else concatMap (depsOfPolymorphicFunction typeEnv env [] "copy" . typesCopyFunctionType)
(filter (isManaged typeEnv) (map snd memberPairs)))
where
path = SymPath pathStrings "copy"
t = FuncTy [RefTy (VarTy "p") (VarTy "q")] (VarTy "p") StaticLifetimeTy
docs = "copies the `" ++ typeName ++ "`."
templateCreator = TemplateCreator $
\typeEnv env ->
Template
t
(const (toTemplate "$p $NAME($p* pRef)"))
( \(FuncTy [RefTy concreteStructTy _] _ _) ->
let mappings = unifySignatures originalStructTy concreteStructTy
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
memberPairs = memberXObjsToPairs correctedMembers
in tokensForCopy typeEnv env memberPairs
)
( \(FuncTy [RefTy concreteStructTy _] _ _) ->
let mappings = unifySignatures originalStructTy concreteStructTy
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
memberPairs = memberXObjsToPairs correctedMembers
in if isTypeGeneric concreteStructTy
then []
else
concatMap
(depsOfPolymorphicFunction typeEnv env [] "copy" . typesCopyFunctionType)
(filter (isManaged typeEnv) (map snd memberPairs))
)

1556
src/Emit.hs
View File

File diff suppressed because it is too large Load Diff

1445
src/Eval.hs
View File

File diff suppressed because it is too large Load Diff

356
src/Expand.hs
View File

@ -1,14 +1,13 @@
module Expand (expandAll, replaceSourceInfoOnXObj) where
import Control.Monad.State (evalState, get, put, State)
import Control.Monad.State (State, evalState, get, put)
import Data.Foldable (foldlM)
import Types
import Obj
import Util
import Lookup
import TypeError
import Info
import Lookup
import Obj
import TypeError
import Types
import Util
-- | Used for calling back to the 'eval' function in Eval.hs
type DynamicEvaluator = Context -> XObj -> IO (Context, Either EvalError XObj)
@ -17,26 +16,29 @@ type DynamicEvaluator = Context -> XObj -> IO (Context, Either EvalError XObj)
-- | Note: comparing environments is tricky! Make sure they *can* be equal, otherwise this won't work at all!
expandAll :: DynamicEvaluator -> Context -> XObj -> IO (Context, Either EvalError XObj)
expandAll eval ctx root =
do (ctx', fullyExpanded) <- expandAllInternal root
pure (ctx', fmap setNewIdentifiers fullyExpanded)
where expandAllInternal xobj =
do (newCtx, expansionResult) <- expand eval ctx xobj
case expansionResult of
Right expanded -> if expanded == xobj
then pure (newCtx, Right expanded)
else expandAll eval newCtx expanded
err -> pure (newCtx, err)
do
(ctx', fullyExpanded) <- expandAllInternal root
pure (ctx', fmap setNewIdentifiers fullyExpanded)
where
expandAllInternal xobj =
do
(newCtx, expansionResult) <- expand eval ctx xobj
case expansionResult of
Right expanded ->
if expanded == xobj
then pure (newCtx, Right expanded)
else expandAll eval newCtx expanded
err -> pure (newCtx, err)
-- | Macro expansion of a single form
expand :: DynamicEvaluator -> Context -> XObj -> IO (Context, Either EvalError XObj)
expand eval ctx xobj =
case xobjObj xobj of
--case obj (trace ("Expand: " ++ pretty xobj) xobj) of
--case obj (trace ("Expand: " ++ pretty xobj) xobj) of
Lst _ -> expandList xobj
Arr _ -> expandArray xobj
Sym _ _ -> expandSymbol xobj
_ -> pure (ctx, Right xobj)
_ -> pure (ctx, Right xobj)
where
expandList :: XObj -> IO (Context, Either EvalError XObj)
expandList (XObj (Lst xobjs) i t) = do
@ -47,111 +49,180 @@ expand eval ctx xobj =
XObj (Deftemplate _) _ _ : _ -> pure (ctx, Right xobj)
XObj (Defalias _) _ _ : _ -> pure (ctx, Right xobj)
[defnExpr@(XObj (Defn _) _ _), name, args, body] ->
do (ctx', expandedBody) <- expand eval ctx body
pure (ctx', do okBody <- expandedBody
Right (XObj (Lst [defnExpr, name, args, okBody]) i t))
do
(ctx', expandedBody) <- expand eval ctx body
pure
( ctx',
do
okBody <- expandedBody
Right (XObj (Lst [defnExpr, name, args, okBody]) i t)
)
[defExpr@(XObj Def _ _), name, expr] ->
do (ctx', expandedExpr) <- expand eval ctx expr
pure (ctx', do okExpr <- expandedExpr
Right (XObj (Lst [defExpr, name, okExpr]) i t))
do
(ctx', expandedExpr) <- expand eval ctx expr
pure
( ctx',
do
okExpr <- expandedExpr
Right (XObj (Lst [defExpr, name, okExpr]) i t)
)
[theExpr@(XObj The _ _), typeXObj, value] ->
do (ctx', expandedValue) <- expand eval ctx value
pure (ctx', do okValue <- expandedValue
Right (XObj (Lst [theExpr, typeXObj, okValue]) i t))
do
(ctx', expandedValue) <- expand eval ctx value
pure
( ctx',
do
okValue <- expandedValue
Right (XObj (Lst [theExpr, typeXObj, okValue]) i t)
)
(XObj The _ _ : _) ->
pure (evalError ctx ("I didn’t understand the `the` at " ++ prettyInfoFromXObj xobj ++ ":\n\n" ++ pretty xobj ++ "\n\nIs it valid? Every `the` needs to follow the form `(the type expression)`.") Nothing)
pure (evalError ctx ("I didn’t understand the `the` at " ++ prettyInfoFromXObj xobj ++ ":\n\n" ++ pretty xobj ++ "\n\nIs it valid? Every `the` needs to follow the form `(the type expression)`.") Nothing)
[ifExpr@(XObj If _ _), condition, trueBranch, falseBranch] ->
do (ctx', expandedCondition) <- expand eval ctx condition
(ctx'', expandedTrueBranch) <- expand eval ctx' trueBranch
(nct, expandedFalseBranch) <- expand eval ctx'' falseBranch
pure (nct, do okCondition <- expandedCondition
okTrueBranch <- expandedTrueBranch
okFalseBranch <- expandedFalseBranch
-- This is a HACK so that each branch of the if statement
-- has a "safe place" (= a do-expression with just one element)
-- where it can store info about its deleters. Without this,
-- An if statement with let-expression inside will duplicate
-- the calls to Delete when emitting code.
let wrappedTrue =
case okTrueBranch of
XObj (Lst (XObj Do _ _ : _)) _ _ -> okTrueBranch -- Has a do-expression already
_ -> XObj (Lst [XObj Do Nothing Nothing, okTrueBranch]) (xobjInfo okTrueBranch) Nothing
wrappedFalse =
case okFalseBranch of
XObj (Lst (XObj Do _ _ : _)) _ _ -> okFalseBranch -- Has a do-expression already
_ -> XObj (Lst [XObj Do Nothing Nothing, okFalseBranch]) (xobjInfo okFalseBranch) Nothing
Right (XObj (Lst [ifExpr, okCondition, wrappedTrue, wrappedFalse]) i t))
do
(ctx', expandedCondition) <- expand eval ctx condition
(ctx'', expandedTrueBranch) <- expand eval ctx' trueBranch
(nct, expandedFalseBranch) <- expand eval ctx'' falseBranch
pure
( nct,
do
okCondition <- expandedCondition
okTrueBranch <- expandedTrueBranch
okFalseBranch <- expandedFalseBranch
-- This is a HACK so that each branch of the if statement
-- has a "safe place" (= a do-expression with just one element)
-- where it can store info about its deleters. Without this,
-- An if statement with let-expression inside will duplicate
-- the calls to Delete when emitting code.
let wrappedTrue =
case okTrueBranch of
XObj (Lst (XObj Do _ _ : _)) _ _ -> okTrueBranch -- Has a do-expression already
_ -> XObj (Lst [XObj Do Nothing Nothing, okTrueBranch]) (xobjInfo okTrueBranch) Nothing
wrappedFalse =
case okFalseBranch of
XObj (Lst (XObj Do _ _ : _)) _ _ -> okFalseBranch -- Has a do-expression already
_ -> XObj (Lst [XObj Do Nothing Nothing, okFalseBranch]) (xobjInfo okFalseBranch) Nothing
Right (XObj (Lst [ifExpr, okCondition, wrappedTrue, wrappedFalse]) i t)
)
[letExpr@(XObj Let _ _), XObj (Arr bindings) bindi bindt, body] ->
if even (length bindings)
then do (ctx', bind) <- foldlM successiveExpandLR (ctx, Right []) (pairwise bindings)
(newCtx, expandedBody) <- expand eval ctx' body
pure (newCtx, do okBindings <- bind
okBody <- expandedBody
Right (XObj (Lst [letExpr, XObj (Arr (concat okBindings)) bindi bindt, okBody]) i t))
else pure (evalError ctx (
"I ecountered an odd number of forms inside a `let` (`" ++
pretty xobj ++ "`)") (xobjInfo xobj))
then do
(ctx', bind) <- foldlM successiveExpandLR (ctx, Right []) (pairwise bindings)
(newCtx, expandedBody) <- expand eval ctx' body
pure
( newCtx,
do
okBindings <- bind
okBody <- expandedBody
Right (XObj (Lst [letExpr, XObj (Arr (concat okBindings)) bindi bindt, okBody]) i t)
)
else
pure
( evalError
ctx
( "I ecountered an odd number of forms inside a `let` (`"
++ pretty xobj
++ "`)"
)
(xobjInfo xobj)
)
matchExpr@(XObj (Match _) _ _) : (expr : rest)
| null rest ->
pure (evalError ctx "I encountered a `match` without forms" (xobjInfo xobj))
pure (evalError ctx "I encountered a `match` without forms" (xobjInfo xobj))
| even (length rest) ->
do (ctx', expandedExpr) <- expand eval ctx expr
(newCtx, expandedPairs) <- foldlM successiveExpandLR (ctx', Right []) (pairwise rest)
pure (newCtx, do okExpandedExpr <- expandedExpr
okExpandedPairs <- expandedPairs
Right (XObj (Lst (matchExpr : okExpandedExpr : (concat okExpandedPairs))) i t))
| otherwise -> pure (evalError ctx
"I encountered an odd number of forms inside a `match`" (xobjInfo xobj))
do
(ctx', expandedExpr) <- expand eval ctx expr
(newCtx, expandedPairs) <- foldlM successiveExpandLR (ctx', Right []) (pairwise rest)
pure
( newCtx,
do
okExpandedExpr <- expandedExpr
okExpandedPairs <- expandedPairs
Right (XObj (Lst (matchExpr : okExpandedExpr : (concat okExpandedPairs))) i t)
)
| otherwise ->
pure
( evalError
ctx
"I encountered an odd number of forms inside a `match`"
(xobjInfo xobj)
)
doExpr@(XObj Do _ _) : expressions ->
do (newCtx, expandedExpressions) <- foldlM successiveExpand (ctx, Right []) expressions
pure (newCtx, do okExpressions <- expandedExpressions
Right (XObj (Lst (doExpr : okExpressions)) i t))
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 _ _) _ _), 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!
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!
)
[(XObj With _ _), _, _] ->
pure (evalError ctx ("I encountered the value `" ++ pretty xobj ++
"` inside a `with` at " ++ prettyInfoFromXObj xobj ++
".\n\n`with` accepts only symbols.") Nothing)
pure
( evalError
ctx
( "I encountered the value `" ++ pretty xobj
++ "` inside a `with` at "
++ prettyInfoFromXObj xobj
++ ".\n\n`with` accepts only symbols."
)
Nothing
)
XObj With _ _ : _ ->
pure (evalError ctx (
"I encountered multiple forms inside a `with` at " ++
prettyInfoFromXObj xobj ++
".\n\n`with` accepts only one expression, except at the top level.") Nothing)
pure
( evalError
ctx
( "I encountered multiple forms inside a `with` at "
++ prettyInfoFromXObj xobj
++ ".\n\n`with` accepts only one expression, except at the top level."
)
Nothing
)
XObj (Mod modEnv) _ _ : args ->
let pathToModule = pathToEnv modEnv
implicitInit = XObj (Sym (SymPath pathToModule "init") Symbol) i t
in expand eval ctx (XObj (Lst (implicitInit : args)) (xobjInfo xobj) (xobjTy xobj))
f:args ->
do (_, expandedF) <- expand eval ctx f
(ctx'', expandedArgs) <- foldlM successiveExpand (ctx, Right []) args
case expandedF of
Right (XObj (Lst [XObj Dynamic _ _, _, XObj (Arr _) _ _, _]) _ _) ->
--trace ("Found dynamic: " ++ pretty xobj)
eval ctx'' xobj
Right (XObj (Lst [XObj Macro _ _, _, XObj (Arr _) _ _, _]) _ _) ->
--trace ("Found macro: " ++ pretty xobj ++ " at " ++ prettyInfoFromXObj xobj)
eval ctx'' xobj
Right (XObj (Lst [XObj (Command callback) _ _, _]) _ _) ->
getCommand callback ctx args
Right _ ->
pure (ctx'', do okF <- expandedF
okArgs <- expandedArgs
Right (XObj (Lst (okF : okArgs)) i t))
Left err -> pure (ctx'', Left err)
in expand eval ctx (XObj (Lst (implicitInit : args)) (xobjInfo xobj) (xobjTy xobj))
f : args ->
do
(_, expandedF) <- expand eval ctx f
(ctx'', expandedArgs) <- foldlM successiveExpand (ctx, Right []) args
case expandedF of
Right (XObj (Lst [XObj Dynamic _ _, _, XObj (Arr _) _ _, _]) _ _) ->
--trace ("Found dynamic: " ++ pretty xobj)
eval ctx'' xobj
Right (XObj (Lst [XObj Macro _ _, _, XObj (Arr _) _ _, _]) _ _) ->
--trace ("Found macro: " ++ pretty xobj ++ " at " ++ prettyInfoFromXObj xobj)
eval ctx'' xobj
Right (XObj (Lst [XObj (Command callback) _ _, _]) _ _) ->
getCommand callback ctx args
Right _ ->
pure
( ctx'',
do
okF <- expandedF
okArgs <- expandedArgs
Right (XObj (Lst (okF : okArgs)) i t)
)
Left err -> pure (ctx'', Left err)
expandList _ = error "Can't expand non-list in expandList."
expandArray :: XObj -> IO (Context, Either EvalError XObj)
expandArray (XObj (Arr xobjs) i t) =
do (newCtx, evaledXObjs) <- foldlM successiveExpand (ctx, Right []) xobjs
pure (newCtx, do okXObjs <- evaledXObjs
Right (XObj (Arr okXObjs) i t))
do
(newCtx, evaledXObjs) <- foldlM successiveExpand (ctx, Right []) xobjs
pure
( newCtx,
do
okXObjs <- evaledXObjs
Right (XObj (Arr okXObjs) i t)
)
expandArray _ = error "Can't expand non-array in expandArray."
expandSymbol :: XObj -> IO (Context, Either EvalError XObj)
expandSymbol sym@(XObj (Sym path _) _ _) =
case lookupInEnv path (contextEnv ctx) of
@ -163,12 +234,13 @@ expand eval ctx xobj =
Just (_, Binder meta (XObj (Lst (XObj (Defalias _) _ _ : _)) _ _)) -> isPrivate meta xobj
Just (_, Binder meta found) -> isPrivate meta found -- use the found value
Nothing -> pure (ctx, Right xobj) -- symbols that are not found are left as-is
where
isPrivate m x = pure $ if metaIsTrue m "private"
then evalError ctx ("The binding: " ++ pretty sym ++ " is private; it may only be used within the module that defines it.") (xobjInfo sym)
else (ctx, Right x)
where
isPrivate m x =
pure $
if metaIsTrue m "private"
then evalError ctx ("The binding: " ++ pretty sym ++ " is private; it may only be used within the module that defines it.") (xobjInfo sym)
else (ctx, Right x)
expandSymbol _ = pure (evalError ctx "Can't expand non-symbol in expandSymbol." Nothing)
successiveExpand (ctx', acc) e =
case acc of
Left _ -> pure (ctx', acc)
@ -177,7 +249,6 @@ expand eval ctx xobj =
pure $ case expanded of
Right err -> (newCtx, Right (lst ++ [err]))
Left err -> (newCtx, Left err)
successiveExpandLR (ctx', acc) (l, r) =
case acc of
Left _ -> pure (ctx', acc)
@ -189,10 +260,12 @@ expand eval ctx xobj =
-- | Replace all the infoIdentifier:s on all nested XObj:s
setNewIdentifiers :: XObj -> XObj
setNewIdentifiers root = let final = evalState (visit root) 0
in final
--trace ("ROOT: " ++ prettyTyped root ++ "FINAL: " ++ prettyTyped final) final
setNewIdentifiers root =
let final = evalState (visit root) 0
in final
where
--trace ("ROOT: " ++ prettyTyped root ++ "FINAL: " ++ prettyTyped final) final
visit :: XObj -> State Int XObj
visit xobj =
case xobjObj xobj of
@ -200,35 +273,35 @@ setNewIdentifiers root = let final = evalState (visit root) 0
(Arr _) -> visitArray xobj
(StaticArr _) -> visitStaticArray xobj
_ -> bumpAndSet xobj
visitList :: XObj -> State Int XObj
visitList (XObj (Lst xobjs) i t) =
do visited <- mapM visit xobjs
let xobj' = XObj (Lst visited) i t
bumpAndSet xobj'
do
visited <- mapM visit xobjs
let xobj' = XObj (Lst visited) i t
bumpAndSet xobj'
visitList _ = error "The function 'visitList' only accepts XObjs with lists in them."
visitArray :: XObj -> State Int XObj
visitArray (XObj (Arr xobjs) i t) =
do visited <- mapM visit xobjs
let xobj' = XObj (Arr visited) i t
bumpAndSet xobj'
do
visited <- mapM visit xobjs
let xobj' = XObj (Arr visited) i t
bumpAndSet xobj'
visitArray _ = error "The function 'visitArray' only accepts XObjs with arrays in them."
visitStaticArray :: XObj -> State Int XObj
visitStaticArray (XObj (StaticArr xobjs) i t) =
do visited <- mapM visit xobjs
let xobj' = XObj (StaticArr visited) i t
bumpAndSet xobj'
do
visited <- mapM visit xobjs
let xobj' = XObj (StaticArr visited) i t
bumpAndSet xobj'
visitStaticArray _ = error "The function 'visitStaticArray' only accepts XObjs with arrays in them."
bumpAndSet :: XObj -> State Int XObj
bumpAndSet xobj =
do counter <- get
put (counter + 1)
pure $ case xobjInfo xobj of
Just i -> (xobj { xobjInfo = Just (i { infoIdentifier = counter })})
Nothing -> xobj
do
counter <- get
put (counter + 1)
pure $ case xobjInfo xobj of
Just i -> (xobj {xobjInfo = Just (i {infoIdentifier = counter})})
Nothing -> xobj
-- | Replaces the file, line and column info on an XObj an all its children.
replaceSourceInfo :: FilePath -> Int -> Int -> XObj -> XObj
@ -240,29 +313,34 @@ replaceSourceInfo newFile newLine newColumn root = visit root
(Lst _) -> visitList xobj
(Arr _) -> visitArray xobj
_ -> setNewInfo xobj
visitList :: XObj -> XObj
visitList (XObj (Lst xobjs) i t) =
setNewInfo (XObj (Lst (map visit xobjs)) i t)
visitList _ =
error "The function 'visitList' only accepts XObjs with lists in them."
visitArray :: XObj -> XObj
visitArray (XObj (Arr xobjs) i t) =
setNewInfo (XObj (Arr (map visit xobjs)) i t)
visitArray _ = error "The function 'visitArray' only accepts XObjs with arrays in them."
setNewInfo :: XObj -> XObj
setNewInfo xobj =
case xobjInfo xobj of
Just i -> (xobj { xobjInfo = Just (i { infoFile = newFile
, infoLine = newLine
, infoColumn = newColumn
})})
Just i ->
( xobj
{ xobjInfo =
Just
( i
{ infoFile = newFile,
infoLine = newLine,
infoColumn = newColumn
}
)
}
)
Nothing -> xobj
replaceSourceInfoOnXObj :: Maybe Info -> XObj -> XObj
replaceSourceInfoOnXObj newInfo xobj =
case newInfo of
Just i -> replaceSourceInfo (infoFile i) (infoLine i) (infoColumn i) xobj
Just i -> replaceSourceInfo (infoFile i) (infoLine i) (infoColumn i) xobj
Nothing -> xobj

605
src/GenerateConstraints.hs
View File

@ -1,310 +1,333 @@
module GenerateConstraints (genConstraints) where
import Control.Arrow hiding(arr)
import Control.Monad.State
import Data.Maybe (mapMaybe, fromMaybe)
import Data.Set as Set
import Data.List as List
import Types
import Obj
import Constraints
import Util
import TypeError
import Control.Arrow hiding (arr)
import Control.Monad.State
import Data.List as List
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Set as Set
import Info
import Obj
import TypeError
import Types
import Util
-- | Will create a list of type constraints for a form.
genConstraints :: Env -> XObj -> Maybe (Ty, XObj) -> Either TypeError [Constraint]
genConstraints _ root rootSig = fmap sort (gen root)
where genF xobj args body captures =
do insideBodyConstraints <- gen body
xobjType <- toEither (xobjTy xobj) (DefnMissingType xobj)
bodyType <- toEither (xobjTy body) (ExpressionMissingType xobj)
let (FuncTy argTys retTy lifetimeTy) = xobjType
bodyConstr = Constraint retTy bodyType xobj body xobj OrdDefnBody
argConstrs = zipWith3 (\a b aObj -> Constraint a b aObj xobj xobj OrdArg) (List.map forceTy args) argTys args
-- The constraint generated by type signatures, like (sig foo (Fn ...)):
-- This constraint is ignored for any xobj != rootxobj (ie. (fn) let bindings)
sigConstr = if root == xobj
then case rootSig of
Just (rootSigTy, rootSigXObj) -> [Constraint rootSigTy xobjType rootSigXObj xobj xobj OrdSignatureAnnotation]
Nothing -> []
else []
captureList :: [XObj]
captureList = Set.toList captures
capturesConstrs = mapMaybe id
(zipWith (\captureTy captureObj ->
case captureTy of
RefTy _ refLt ->
--trace ("Generated constraint between " ++ show lifetimeTy ++ " and " ++ show refLt) $
Just (Constraint lifetimeTy refLt captureObj xobj xobj OrdCapture)
_ ->
--trace ("Did not generate constraint for captured variable " ++ show captureObj) $
Nothing)
(List.map forceTy captureList)
captureList)
pure (bodyConstr : argConstrs ++ insideBodyConstraints ++ capturesConstrs ++ sigConstr)
gen xobj =
case xobjObj xobj of
Lst lst -> case lst of
-- Defn
[XObj (Defn captures) _ _, _, XObj (Arr args) _ _, body] ->
genF xobj args body (fromMaybe Set.empty captures)
where
genF xobj args body captures =
do
insideBodyConstraints <- gen body
xobjType <- toEither (xobjTy xobj) (DefnMissingType xobj)
bodyType <- toEither (xobjTy body) (ExpressionMissingType xobj)
let (FuncTy argTys retTy lifetimeTy) = xobjType
bodyConstr = Constraint retTy bodyType xobj body xobj OrdDefnBody
argConstrs = zipWith3 (\a b aObj -> Constraint a b aObj xobj xobj OrdArg) (List.map forceTy args) argTys args
-- The constraint generated by type signatures, like (sig foo (Fn ...)):
-- This constraint is ignored for any xobj != rootxobj (ie. (fn) let bindings)
sigConstr =
if root == xobj
then case rootSig of
Just (rootSigTy, rootSigXObj) -> [Constraint rootSigTy xobjType rootSigXObj xobj xobj OrdSignatureAnnotation]
Nothing -> []
else []
captureList :: [XObj]
captureList = Set.toList captures
capturesConstrs =
mapMaybe
id
( zipWith
( \captureTy captureObj ->
case captureTy of
RefTy _ refLt ->
--trace ("Generated constraint between " ++ show lifetimeTy ++ " and " ++ show refLt) $
Just (Constraint lifetimeTy refLt captureObj xobj xobj OrdCapture)
_ ->
--trace ("Did not generate constraint for captured variable " ++ show captureObj) $
Nothing
)
(List.map forceTy captureList)
captureList
)
pure (bodyConstr : argConstrs ++ insideBodyConstraints ++ capturesConstrs ++ sigConstr)
gen xobj =
case xobjObj xobj of
Lst lst -> case lst of
-- Defn
[XObj (Defn captures) _ _, _, XObj (Arr args) _ _, body] ->
genF xobj args body (fromMaybe Set.empty captures)
-- Fn
[XObj (Fn _ captures) _ _, XObj (Arr args) _ _, body] ->
genF xobj args body captures
-- Def
[XObj Def _ _, _, expr] ->
do
insideExprConstraints <- gen expr
xobjType <- toEither (xobjTy xobj) (DefMissingType xobj)
exprType <- toEither (xobjTy expr) (ExpressionMissingType xobj)
let defConstraint = Constraint xobjType exprType xobj expr xobj OrdDefExpr
sigConstr = case rootSig of
Just (rootSigTy, rootSigXObj) -> [Constraint rootSigTy xobjType rootSigXObj xobj xobj OrdSignatureAnnotation]
Nothing -> []
pure (defConstraint : insideExprConstraints ++ sigConstr)
-- Let
[XObj Let _ _, XObj (Arr bindings) _ _, body] ->
do
insideBodyConstraints <- gen body
insideBindingsConstraints <- fmap join (mapM gen bindings)
bodyType <- toEither (xobjTy body) (ExpressionMissingType body)
let Just xobjTy' = xobjTy xobj
wholeStatementConstraint = Constraint bodyType xobjTy' body xobj xobj OrdLetBody
bindingsConstraints =
zipWith
( \(symTy, exprTy) (symObj, exprObj) ->
Constraint symTy exprTy symObj exprObj xobj OrdLetBind
)
(List.map (forceTy *** forceTy) (pairwise bindings))
(pairwise bindings)
pure
( wholeStatementConstraint : insideBodyConstraints
++ bindingsConstraints
++ insideBindingsConstraints
)
-- If
[XObj If _ _, expr, ifTrue, ifFalse] ->
do
insideConditionConstraints <- gen expr
insideTrueConstraints <- gen ifTrue
insideFalseConstraints <- gen ifFalse
exprType <- toEither (xobjTy expr) (ExpressionMissingType expr)
trueType <- toEither (xobjTy ifTrue) (ExpressionMissingType ifTrue)
falseType <- toEither (xobjTy ifFalse) (ExpressionMissingType ifFalse)
let expected = XObj (Sym (SymPath [] "Condition in if value") Symbol) (xobjInfo expr) (Just BoolTy)
let conditionConstraint = Constraint exprType BoolTy expr expected xobj OrdIfCondition
sameReturnConstraint = Constraint trueType falseType ifTrue ifFalse xobj OrdIfReturn
Just t = xobjTy xobj
wholeStatementConstraint = Constraint trueType t ifTrue xobj xobj OrdIfWhole
pure
( conditionConstraint : sameReturnConstraint
: wholeStatementConstraint
: insideConditionConstraints
++ insideTrueConstraints
++ insideFalseConstraints
)
-- Match
XObj (Match matchMode) _ _ : expr : cases ->
do
insideExprConstraints <- gen expr
casesLhsConstraints <- fmap join (mapM (genConstraintsForCaseMatcher matchMode . fst) (pairwise cases))
casesRhsConstraints <- fmap join (mapM (gen . snd) (pairwise cases))
exprType <- toEither (xobjTy expr) (ExpressionMissingType expr)
xobjType <- toEither (xobjTy xobj) (DefMissingType xobj)
let -- Each case rhs should have the same return type as the whole match form:
mkRetConstr x@(XObj _ _ (Just t)) = Just (Constraint t xobjType x xobj xobj OrdArg) -- TODO: Ord
mkRetConstr _ = Nothing
returnConstraints = mapMaybe (\(_, rhs) -> mkRetConstr rhs) (pairwise cases)
-- Each case lhs should have the same type as the expression matching on
mkExprConstr x@(XObj _ _ (Just t)) = Just (Constraint (wrapTyInRefIfMatchingRef t) exprType x expr xobj OrdArg) -- TODO: Ord
mkExprConstr _ = Nothing
exprConstraints = mapMaybe (\(lhs, _) -> mkExprConstr lhs) (pairwise cases)
-- Constraints for the variables in the left side of each matching case,
-- like the 'r'/'g'/'b' in (match col (RGB r g b) ...) being constrained to Int.
-- casesLhsConstraints = concatMap (genLhsConstraintsInCase typeEnv exprType) (map fst (pairwise cases))
-- Fn
[XObj (Fn _ captures) _ _, XObj (Arr args) _ _, body] ->
genF xobj args body captures
-- exprConstraint =
-- -- | TODO: Only guess if there isn't already a type set on the expression!
-- case guessExprType typeEnv cases of
-- Just guessedExprTy ->
-- let expected = XObj (Sym (SymPath [] "Expression in match-statement") Symbol)
-- (info expr) (Just guessedExprTy)
-- in [Constraint exprType guessedExprTy expr expected OrdIfCondition] -- TODO: Ord
-- Nothing ->
-- []
-- Def
[XObj Def _ _, _, expr] ->
do insideExprConstraints <- gen expr
xobjType <- toEither (xobjTy xobj) (DefMissingType xobj)
exprType <- toEither (xobjTy expr) (ExpressionMissingType xobj)
let defConstraint = Constraint xobjType exprType xobj expr xobj OrdDefExpr
sigConstr = case rootSig of
Just (rootSigTy, rootSigXObj) -> [Constraint rootSigTy xobjType rootSigXObj xobj xobj OrdSignatureAnnotation]
Nothing -> []
pure (defConstraint : insideExprConstraints ++ sigConstr)
-- Let
[XObj Let _ _, XObj (Arr bindings) _ _, body] ->
do insideBodyConstraints <- gen body
insideBindingsConstraints <- fmap join (mapM gen bindings)
bodyType <- toEither (xobjTy body) (ExpressionMissingType body)
let Just xobjTy' = xobjTy xobj
wholeStatementConstraint = Constraint bodyType xobjTy' body xobj xobj OrdLetBody
bindingsConstraints = zipWith (\(symTy, exprTy) (symObj, exprObj) ->
Constraint symTy exprTy symObj exprObj xobj OrdLetBind)
(List.map (forceTy *** forceTy) (pairwise bindings))
(pairwise bindings)
pure (wholeStatementConstraint : insideBodyConstraints ++
bindingsConstraints ++ insideBindingsConstraints)
-- If
[XObj If _ _, expr, ifTrue, ifFalse] ->
do insideConditionConstraints <- gen expr
insideTrueConstraints <- gen ifTrue
insideFalseConstraints <- gen ifFalse
exprType <- toEither (xobjTy expr) (ExpressionMissingType expr)
trueType <- toEither (xobjTy ifTrue) (ExpressionMissingType ifTrue)
falseType <- toEither (xobjTy ifFalse) (ExpressionMissingType ifFalse)
let expected = XObj (Sym (SymPath [] "Condition in if value") Symbol) (xobjInfo expr) (Just BoolTy)
let conditionConstraint = Constraint exprType BoolTy expr expected xobj OrdIfCondition
sameReturnConstraint = Constraint trueType falseType ifTrue ifFalse xobj OrdIfReturn
Just t = xobjTy xobj
wholeStatementConstraint = Constraint trueType t ifTrue xobj xobj OrdIfWhole
pure (conditionConstraint : sameReturnConstraint :
wholeStatementConstraint : insideConditionConstraints ++
insideTrueConstraints ++ insideFalseConstraints)
-- Match
XObj (Match matchMode) _ _ : expr : cases ->
do insideExprConstraints <- gen expr
casesLhsConstraints <- fmap join (mapM (genConstraintsForCaseMatcher matchMode . fst) (pairwise cases))
casesRhsConstraints <- fmap join (mapM (gen . snd) (pairwise cases))
exprType <- toEither (xobjTy expr) (ExpressionMissingType expr)
xobjType <- toEither (xobjTy xobj) (DefMissingType xobj)
let
-- Each case rhs should have the same return type as the whole match form:
mkRetConstr x@(XObj _ _ (Just t)) = Just (Constraint t xobjType x xobj xobj OrdArg) -- | TODO: Ord
mkRetConstr _ = Nothing
returnConstraints = mapMaybe (\(_, rhs) -> mkRetConstr rhs) (pairwise cases)
-- Each case lhs should have the same type as the expression matching on
mkExprConstr x@(XObj _ _ (Just t)) = Just (Constraint (wrapTyInRefIfMatchingRef t) exprType x expr xobj OrdArg) -- | TODO: Ord
mkExprConstr _ = Nothing
exprConstraints = mapMaybe (\(lhs, _) -> mkExprConstr lhs) (pairwise cases)
-- Constraints for the variables in the left side of each matching case,
-- like the 'r'/'g'/'b' in (match col (RGB r g b) ...) being constrained to Int.
-- casesLhsConstraints = concatMap (genLhsConstraintsInCase typeEnv exprType) (map fst (pairwise cases))
-- exprConstraint =
-- -- | TODO: Only guess if there isn't already a type set on the expression!
-- case guessExprType typeEnv cases of
-- Just guessedExprTy ->
-- let expected = XObj (Sym (SymPath [] "Expression in match-statement") Symbol)
-- (info expr) (Just guessedExprTy)
-- in [Constraint exprType guessedExprTy expr expected OrdIfCondition] -- | TODO: Ord
-- Nothing ->
-- []
pure (insideExprConstraints ++
casesLhsConstraints ++
casesRhsConstraints ++
returnConstraints ++
exprConstraints)
where wrapTyInRefIfMatchingRef t =
case matchMode of
MatchValue -> t
MatchRef -> RefTy t (VarTy "whatever")
-- While
[XObj While _ _, expr, body] ->
do insideConditionConstraints <- gen expr
insideBodyConstraints <- gen body
exprType <- toEither (xobjTy expr) (ExpressionMissingType expr)
bodyType <- toEither (xobjTy body) (ExpressionMissingType body)
let expectedCond = XObj (Sym (SymPath [] "Condition in while-expression") Symbol) (xobjInfo expr) (Just BoolTy)
expectedBody = XObj (Sym (SymPath [] "Body in while-expression") Symbol) (xobjInfo xobj) (Just UnitTy)
conditionConstraint = Constraint exprType BoolTy expr expectedCond xobj OrdWhileCondition
wholeStatementConstraint = Constraint bodyType UnitTy body expectedBody xobj OrdWhileBody
pure (conditionConstraint : wholeStatementConstraint :
insideConditionConstraints ++ insideBodyConstraints)
-- Do
XObj Do _ _ : expressions ->
case expressions of
[] -> Left (NoStatementsInDo xobj)
_ -> let lastExpr = last expressions
in do insideExpressionsConstraints <- fmap join (mapM gen expressions)
xobjType <- toEither (xobjTy xobj) (DefMissingType xobj)
lastExprType <- toEither (xobjTy lastExpr) (ExpressionMissingType xobj)
let retConstraint = Constraint xobjType lastExprType xobj lastExpr xobj OrdDoReturn
must = XObj (Sym (SymPath [] "Statement in do-expression") Symbol) (xobjInfo xobj) (Just UnitTy)
mkConstr x@(XObj _ _ (Just t)) = Just (Constraint t UnitTy x must xobj OrdDoStatement)
mkConstr _ = Nothing
expressionsShouldReturnUnit = mapMaybe mkConstr (init expressions)
pure (retConstraint : insideExpressionsConstraints ++ expressionsShouldReturnUnit)
-- Address
[XObj Address _ _, value] ->
gen value
-- Set!
[XObj SetBang _ _, variable, value] ->
do insideValueConstraints <- gen value
insideVariableConstraints <- gen variable
variableType <- toEither (xobjTy variable) (ExpressionMissingType variable)
valueType <- toEither (xobjTy value) (ExpressionMissingType value)
let sameTypeConstraint = Constraint variableType valueType variable value xobj OrdSetBang
pure (sameTypeConstraint : insideValueConstraints ++ insideVariableConstraints)
-- The
[XObj The _ _, _, value] ->
do insideValueConstraints <- gen value
xobjType <- toEither (xobjTy xobj) (DefMissingType xobj)
valueType <- toEither (xobjTy value) (DefMissingType value)
let theTheConstraint = Constraint xobjType valueType xobj value xobj OrdThe
pure (theTheConstraint : insideValueConstraints)
-- Ref
[XObj Ref _ _, value] ->
gen value
-- Deref
[XObj Deref _ _, value] ->
do insideValueConstraints <- gen value
xobjType <- toEither (xobjTy xobj) (ExpressionMissingType xobj)
valueType <- toEither (xobjTy value) (ExpressionMissingType value)
let lt = VarTy (makeTypeVariableNameFromInfo (xobjInfo xobj))
let theTheConstraint = Constraint (RefTy xobjType lt) valueType xobj value xobj OrdDeref
pure (theTheConstraint : insideValueConstraints)
-- Break
[XObj Break _ _] ->
pure []
-- Function application
func : args ->
do funcConstraints <- gen func
variablesConstraints <- fmap join (mapM gen args)
funcTy <- toEither (xobjTy func) (ExpressionMissingType func)
case funcTy of
(FuncTy argTys retTy _) ->
if length args /= length argTys then
Left (WrongArgCount func (length argTys) (length args))
else
let expected t n =
XObj (Sym (SymPath [] ("Expected " ++ enumerate n ++ " argument to '" ++ getName func ++ "'")) Symbol)
(xobjInfo func) (Just t)
argConstraints = zipWith4 (\a t aObj n -> Constraint a t aObj (expected t n) xobj OrdFuncAppArg)
(List.map forceTy args)
argTys
args
[0..]
Just xobjTy' = xobjTy xobj
retConstraint = Constraint xobjTy' retTy xobj func xobj OrdFuncAppRet
in pure (retConstraint : funcConstraints ++ argConstraints ++ variablesConstraints)
funcVarTy@(VarTy _) ->
let fabricatedFunctionType = FuncTy (List.map forceTy args) (forceTy xobj) (VarTy "what?!")
expected = XObj (Sym (SymPath [] ("Calling '" ++ getName func ++ "'")) Symbol) (xobjInfo func) Nothing
wholeTypeConstraint = Constraint funcVarTy fabricatedFunctionType func expected xobj OrdFuncAppVarTy
in pure (wholeTypeConstraint : funcConstraints ++ variablesConstraints)
_ -> Left (NotAFunction func)
-- Empty list
[] -> Right []
(Arr arr) ->
case arr of
[] -> Right []
x:xs -> do insideExprConstraints <- fmap join (mapM gen arr)
let Just headTy = xobjTy x
genObj o n = XObj (Sym (SymPath [] ("Whereas the " ++ enumerate n ++ " element in the array is " ++ show (getPath o))) Symbol)
(xobjInfo o) (xobjTy o)
headObj = XObj (Sym (SymPath [] ("I inferred the type of the array from its first element " ++ show (getPath x))) Symbol)
(xobjInfo x) (Just headTy)
Just (StructTy (ConcreteNameTy "Array") [t]) = xobjTy xobj
betweenExprConstraints = zipWith (\o n -> Constraint headTy (forceTy o) headObj (genObj o n) xobj OrdArrBetween) xs [1..]
headConstraint = Constraint headTy t headObj (genObj x 1) xobj OrdArrHead
pure (headConstraint : insideExprConstraints ++ betweenExprConstraints)
-- THIS CODE IS VERY MUCH A DUPLICATION OF THE 'ARR' CODE FROM ABOVE:
(StaticArr arr) ->
case arr of
[] -> Right []
x:xs -> do insideExprConstraints <- fmap join (mapM gen arr)
let Just headTy = xobjTy x
genObj o n = XObj (Sym (SymPath [] ("Whereas the " ++ enumerate n ++ " element in the array is " ++ show (getPath o))) Symbol)
(xobjInfo o) (xobjTy o)
headObj = XObj (Sym (SymPath [] ("I inferred the type of the static array from its first element " ++ show (getPath x))) Symbol)
(xobjInfo x) (Just headTy)
Just (RefTy(StructTy (ConcreteNameTy "StaticArray") [t]) _) = xobjTy xobj
betweenExprConstraints = zipWith (\o n -> Constraint headTy (forceTy o) headObj (genObj o n) xobj OrdArrBetween) xs [1..]
headConstraint = Constraint headTy t headObj (genObj x 1) xobj OrdArrHead
pure (headConstraint : insideExprConstraints ++ betweenExprConstraints)
_ -> Right []
pure
( insideExprConstraints
++ casesLhsConstraints
++ casesRhsConstraints
++ returnConstraints
++ exprConstraints
)
where
wrapTyInRefIfMatchingRef t =
case matchMode of
MatchValue -> t
MatchRef -> RefTy t (VarTy "whatever")
-- While
[XObj While _ _, expr, body] ->
do
insideConditionConstraints <- gen expr
insideBodyConstraints <- gen body
exprType <- toEither (xobjTy expr) (ExpressionMissingType expr)
bodyType <- toEither (xobjTy body) (ExpressionMissingType body)
let expectedCond = XObj (Sym (SymPath [] "Condition in while-expression") Symbol) (xobjInfo expr) (Just BoolTy)
expectedBody = XObj (Sym (SymPath [] "Body in while-expression") Symbol) (xobjInfo xobj) (Just UnitTy)
conditionConstraint = Constraint exprType BoolTy expr expectedCond xobj OrdWhileCondition
wholeStatementConstraint = Constraint bodyType UnitTy body expectedBody xobj OrdWhileBody
pure
( conditionConstraint : wholeStatementConstraint
: insideConditionConstraints ++ insideBodyConstraints
)
-- Do
XObj Do _ _ : expressions ->
case expressions of
[] -> Left (NoStatementsInDo xobj)
_ ->
let lastExpr = last expressions
in do
insideExpressionsConstraints <- fmap join (mapM gen expressions)
xobjType <- toEither (xobjTy xobj) (DefMissingType xobj)
lastExprType <- toEither (xobjTy lastExpr) (ExpressionMissingType xobj)
let retConstraint = Constraint xobjType lastExprType xobj lastExpr xobj OrdDoReturn
must = XObj (Sym (SymPath [] "Statement in do-expression") Symbol) (xobjInfo xobj) (Just UnitTy)
mkConstr x@(XObj _ _ (Just t)) = Just (Constraint t UnitTy x must xobj OrdDoStatement)
mkConstr _ = Nothing
expressionsShouldReturnUnit = mapMaybe mkConstr (init expressions)
pure (retConstraint : insideExpressionsConstraints ++ expressionsShouldReturnUnit)
-- Address
[XObj Address _ _, value] ->
gen value
-- Set!
[XObj SetBang _ _, variable, value] ->
do
insideValueConstraints <- gen value
insideVariableConstraints <- gen variable
variableType <- toEither (xobjTy variable) (ExpressionMissingType variable)
valueType <- toEither (xobjTy value) (ExpressionMissingType value)
let sameTypeConstraint = Constraint variableType valueType variable value xobj OrdSetBang
pure (sameTypeConstraint : insideValueConstraints ++ insideVariableConstraints)
-- The
[XObj The _ _, _, value] ->
do
insideValueConstraints <- gen value
xobjType <- toEither (xobjTy xobj) (DefMissingType xobj)
valueType <- toEither (xobjTy value) (DefMissingType value)
let theTheConstraint = Constraint xobjType valueType xobj value xobj OrdThe
pure (theTheConstraint : insideValueConstraints)
-- Ref
[XObj Ref _ _, value] ->
gen value
-- Deref
[XObj Deref _ _, value] ->
do
insideValueConstraints <- gen value
xobjType <- toEither (xobjTy xobj) (ExpressionMissingType xobj)
valueType <- toEither (xobjTy value) (ExpressionMissingType value)
let lt = VarTy (makeTypeVariableNameFromInfo (xobjInfo xobj))
let theTheConstraint = Constraint (RefTy xobjType lt) valueType xobj value xobj OrdDeref
pure (theTheConstraint : insideValueConstraints)
-- Break
[XObj Break _ _] ->
pure []
-- Function application
func : args ->
do
funcConstraints <- gen func
variablesConstraints <- fmap join (mapM gen args)
funcTy <- toEither (xobjTy func) (ExpressionMissingType func)
case funcTy of
(FuncTy argTys retTy _) ->
if length args /= length argTys
then Left (WrongArgCount func (length argTys) (length args))
else
let expected t n =
XObj
(Sym (SymPath [] ("Expected " ++ enumerate n ++ " argument to '" ++ getName func ++ "'")) Symbol)
(xobjInfo func)
(Just t)
argConstraints =
zipWith4
(\a t aObj n -> Constraint a t aObj (expected t n) xobj OrdFuncAppArg)
(List.map forceTy args)
argTys
args
[0 ..]
Just xobjTy' = xobjTy xobj
retConstraint = Constraint xobjTy' retTy xobj func xobj OrdFuncAppRet
in pure (retConstraint : funcConstraints ++ argConstraints ++ variablesConstraints)
funcVarTy@(VarTy _) ->
let fabricatedFunctionType = FuncTy (List.map forceTy args) (forceTy xobj) (VarTy "what?!")
expected = XObj (Sym (SymPath [] ("Calling '" ++ getName func ++ "'")) Symbol) (xobjInfo func) Nothing
wholeTypeConstraint = Constraint funcVarTy fabricatedFunctionType func expected xobj OrdFuncAppVarTy
in pure (wholeTypeConstraint : funcConstraints ++ variablesConstraints)
_ -> Left (NotAFunction func)
-- Empty list
[] -> Right []
(Arr arr) ->
case arr of
[] -> Right []
x : xs -> do
insideExprConstraints <- fmap join (mapM gen arr)
let Just headTy = xobjTy x
genObj o n =
XObj
(Sym (SymPath [] ("Whereas the " ++ enumerate n ++ " element in the array is " ++ show (getPath o))) Symbol)
(xobjInfo o)
(xobjTy o)
headObj =
XObj
(Sym (SymPath [] ("I inferred the type of the array from its first element " ++ show (getPath x))) Symbol)
(xobjInfo x)
(Just headTy)
Just (StructTy (ConcreteNameTy "Array") [t]) = xobjTy xobj
betweenExprConstraints = zipWith (\o n -> Constraint headTy (forceTy o) headObj (genObj o n) xobj OrdArrBetween) xs [1 ..]
headConstraint = Constraint headTy t headObj (genObj x 1) xobj OrdArrHead
pure (headConstraint : insideExprConstraints ++ betweenExprConstraints)
-- THIS CODE IS VERY MUCH A DUPLICATION OF THE 'ARR' CODE FROM ABOVE:
(StaticArr arr) ->
case arr of
[] -> Right []
x : xs -> do
insideExprConstraints <- fmap join (mapM gen arr)
let Just headTy = xobjTy x
genObj o n =
XObj
(Sym (SymPath [] ("Whereas the " ++ enumerate n ++ " element in the array is " ++ show (getPath o))) Symbol)
(xobjInfo o)
(xobjTy o)
headObj =
XObj
(Sym (SymPath [] ("I inferred the type of the static array from its first element " ++ show (getPath x))) Symbol)
(xobjInfo x)
(Just headTy)
Just (RefTy (StructTy (ConcreteNameTy "StaticArray") [t]) _) = xobjTy xobj
betweenExprConstraints = zipWith (\o n -> Constraint headTy (forceTy o) headObj (genObj o n) xobj OrdArrBetween) xs [1 ..]
headConstraint = Constraint headTy t headObj (genObj x 1) xobj OrdArrHead
pure (headConstraint : insideExprConstraints ++ betweenExprConstraints)
_ -> Right []
genConstraintsForCaseMatcher :: MatchMode -> XObj -> Either TypeError [Constraint]
genConstraintsForCaseMatcher matchMode = gen
where
-- | NOTE: This works very similar to generating constraints for function calls
-- | since the cases for sumtypes *are* functions. So we rely on those symbols to
-- | already have the correct type, e.g. in (match foo (Just x) x) the 'Just' case name
-- | has the type (Fn [Int] Maybe) which is exactly what we need to give 'x' the correct type.
gen xobj@(XObj (Lst (caseName : variables)) _ _) =
do caseNameConstraints <- gen caseName
variablesConstraints <- fmap join (mapM gen variables)
caseNameTy <- toEither (xobjTy caseName) (ExpressionMissingType caseName)
case caseNameTy of
(FuncTy argTys retTy _) ->
if length variables /= length argTys then
Left (WrongArgCount caseName (length argTys) (length variables)) -- | TODO: This could be another error since this isn't an actual function call.
else
let expected t n = XObj (Sym (SymPath [] ("Expected " ++ enumerate n ++ " argument to '" ++ getName caseName ++ "'")) Symbol) (xobjInfo caseName) (Just t)
argConstraints = zipWith4 (\a t aObj n -> Constraint a t aObj (expected t n) xobj OrdFuncAppArg)
(List.map forceTy variables)
(zipWith refWrapper variables argTys)
variables
[0..]
Just xobjTy' = xobjTy xobj
retConstraint = Constraint xobjTy' retTy xobj caseName xobj OrdFuncAppRet
in pure (retConstraint : caseNameConstraints ++ argConstraints ++ variablesConstraints)
funcVarTy@(VarTy _) ->
let fabricatedFunctionType = FuncTy (List.map forceTy variables) (forceTy xobj) (VarTy "what?!") -- | TODO: Fix
expected = XObj (Sym (SymPath [] ("Matchin on '" ++ getName caseName ++ "'")) Symbol) (xobjInfo caseName) Nothing
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.
do
caseNameConstraints <- gen caseName
variablesConstraints <- fmap join (mapM gen variables)
caseNameTy <- toEither (xobjTy caseName) (ExpressionMissingType caseName)
case caseNameTy of
(FuncTy argTys retTy _) ->
if length variables /= length argTys
then Left (WrongArgCount caseName (length argTys) (length variables)) -- TODO: This could be another error since this isn't an actual function call.
else
let expected t n = XObj (Sym (SymPath [] ("Expected " ++ enumerate n ++ " argument to '" ++ getName caseName ++ "'")) Symbol) (xobjInfo caseName) (Just t)
argConstraints =
zipWith4
(\a t aObj n -> Constraint a t aObj (expected t n) xobj OrdFuncAppArg)
(List.map forceTy variables)
(zipWith refWrapper variables argTys)
variables
[0 ..]
Just xobjTy' = xobjTy xobj
retConstraint = Constraint xobjTy' retTy xobj caseName xobj OrdFuncAppRet
in pure (retConstraint : caseNameConstraints ++ argConstraints ++ variablesConstraints)
funcVarTy@(VarTy _) ->
let fabricatedFunctionType = FuncTy (List.map forceTy variables) (forceTy xobj) (VarTy "what?!") -- TODO: Fix
expected = XObj (Sym (SymPath [] ("Matchin on '" ++ getName caseName ++ "'")) Symbol) (xobjInfo caseName) Nothing
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 _ = 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.
-- | This will make sure we don't take ownership over the sumtype:s members, which would be catastrophic due to it not being owned by the match.
refWrapper :: XObj -> Ty -> Ty
refWrapper (XObj (Sym _ _) _ _) wrapThisType = wrapInRefTyIfMatchRef matchMode wrapThisType
refWrapper _ t = t

65
src/Infer.hs
View File

@ -1,20 +1,22 @@
module Infer (annotate
,initialTypes
,genConstraints
,assignTypes
,concretizeXObj
,manageMemory
,depsOfPolymorphicFunction
) where
module Infer
( annotate,
initialTypes,
genConstraints,
assignTypes,
concretizeXObj,
manageMemory,
depsOfPolymorphicFunction,
)
where
import Obj
import Constraints
import Types
import TypeError
import InitialTypes
import AssignTypes
import GenerateConstraints
import Concretize
import Constraints
import GenerateConstraints
import InitialTypes
import Obj
import TypeError
import Types
-- | Performs all the steps of creating initial types, solving constraints and assigning the types.
-- | Returns a list of all the bindings that need to be added for the new form to work.
@ -22,22 +24,24 @@ import Concretize
-- | makes it possible to solve more types so let's do it several times.
annotate :: TypeEnv -> Env -> XObj -> Maybe (Ty, XObj) -> Either TypeError (XObj, [XObj])
annotate typeEnv globalEnv xobj rootSig =
do initiated <- initialTypes typeEnv globalEnv xobj
(annotated, dependencies) <- annotateUntilDone typeEnv globalEnv initiated rootSig [] 100
(final, deleteDeps) <- manageMemory typeEnv globalEnv annotated
finalWithNiceTypes <- beautifyTypeVariables final
pure (finalWithNiceTypes, dependencies ++ deleteDeps)
do
initiated <- initialTypes typeEnv globalEnv xobj
(annotated, dependencies) <- annotateUntilDone typeEnv globalEnv initiated rootSig [] 100
(final, deleteDeps) <- manageMemory typeEnv globalEnv annotated
finalWithNiceTypes <- beautifyTypeVariables final
pure (finalWithNiceTypes, dependencies ++ deleteDeps)
-- | Call the 'annotateOne' function until nothing changes
annotateUntilDone :: TypeEnv -> Env -> XObj -> Maybe (Ty, XObj) -> [XObj] -> Int -> Either TypeError (XObj, [XObj])
annotateUntilDone typeEnv globalEnv xobj rootSig deps limiter =
if limiter <= 0
then Left (TooManyAnnotateCalls xobj)
else do (xobj', deps') <- annotateOne typeEnv globalEnv xobj rootSig True
let newDeps = deps ++ deps'
if xobj == xobj' -- Is it the same?
then pure (xobj', newDeps)
else annotateUntilDone typeEnv globalEnv xobj' rootSig newDeps (limiter - 1)
then Left (TooManyAnnotateCalls xobj)
else do
(xobj', deps') <- annotateOne typeEnv globalEnv xobj rootSig True
let newDeps = deps ++ deps'
if xobj == xobj' -- Is it the same?
then pure (xobj', newDeps)
else annotateUntilDone typeEnv globalEnv xobj' rootSig newDeps (limiter - 1)
-- | Performs ONE step of annotation. The 'annotate' function will call this function several times.
-- | TODO: Remove the allowAmbiguity flag?
@ -52,9 +56,12 @@ annotateOne typeEnv env xobj rootSig allowAmbiguity = do
solveConstraintsAndConvertErrorIfNeeded :: [Constraint] -> Either TypeError TypeMappings
solveConstraintsAndConvertErrorIfNeeded constraints =
case solve constraints of
Left failure@(UnificationFailure _ _) -> Left (UnificationFailed
(unificationFailure failure)
(unificationMappings failure)
constraints)
Left failure@(UnificationFailure _ _) ->
Left
( UnificationFailed
(unificationFailure failure)
(unificationMappings failure)
constraints
)
Left (Holes holes) -> Left (HolesFound holes)
Right ok -> Right ok

86
src/Info.hs
View File

@ -1,41 +1,53 @@
-- | Module Info defines data types and functions for reporting details about
-- the Carp forms in a source file.
module Info (Info(..),
Deleter(..),
FilePathPrintLength(..),
dummyInfo,
getInfo,
prettyInfo,
freshVar,
machineReadableInfo,
makeTypeVariableNameFromInfo) where
module Info
( Info (..),
Deleter (..),
FilePathPrintLength (..),
dummyInfo,
getInfo,
prettyInfo,
freshVar,
machineReadableInfo,
makeTypeVariableNameFromInfo,
)
where
import qualified Data.Set as Set
import Path (takeFileName)
import SymPath
-- | Information about where the Obj originated from.
data Info = Info { infoLine :: Int
, infoColumn :: Int
, infoFile :: String
, infoDelete :: Set.Set Deleter
, infoIdentifier :: Int
} deriving (Show, Eq, Ord)
data Info
= Info
{ infoLine :: Int,
infoColumn :: Int,
infoFile :: String,
infoDelete :: Set.Set Deleter,
infoIdentifier :: Int
}
deriving (Show, Eq, Ord)
-- TODO: The name 'deleter' for these things are really confusing!
-- | Designates the deleter function for a Carp object.
data Deleter = ProperDeleter { deleterPath :: SymPath
, deleterVariable :: String
}
-- used for external types with no delete function
| FakeDeleter { deleterVariable :: String
}
-- used by primitive types (i.e. Int) to signify that the variable is alive
| PrimDeleter { aliveVariable :: String
}
| RefDeleter { refVariable :: String
}
deriving (Eq, Ord)
data Deleter
= ProperDeleter
{ deleterPath :: SymPath,
deleterVariable :: String
}
| -- used for external types with no delete function
FakeDeleter
{ deleterVariable :: String
}
| -- used by primitive types (i.e. Int) to signify that the variable is alive
PrimDeleter
{ aliveVariable :: String
}
| RefDeleter
{ refVariable :: String
}
deriving (Eq, Ord)
instance Show Deleter where
show (ProperDeleter path var) = "(ProperDel " ++ show path ++ " " ++ show var ++ ")"
@ -45,8 +57,10 @@ instance Show Deleter where
-- | Whether or not the full path of a source file or a short path should be
-- printed.
data FilePathPrintLength = FullPath
| ShortPath deriving Eq
data FilePathPrintLength
= FullPath
| ShortPath
deriving (Eq)
instance Show FilePathPrintLength where
show FullPath = "full"
@ -66,9 +80,11 @@ getInfo i = (infoLine i, infoColumn i, infoFile i)
prettyInfo :: Info -> String
prettyInfo i =
let (line, column, file) = getInfo i
in (if line > -1 then "line " ++ show line else "unknown line") ++ ", " ++
(if column > -1 then "column " ++ show column else "unknown column") ++
" in '" ++ file ++ "'"
in (if line > -1 then "line " ++ show line else "unknown line") ++ ", "
++ (if column > -1 then "column " ++ show column else "unknown column")
++ " in '"
++ file
++ "'"
-- TODO: change name of this function
freshVar :: Info -> String
@ -79,9 +95,9 @@ machineReadableInfo :: FilePathPrintLength -> Info -> String
machineReadableInfo filePathPrintLength i =
let (line, column, file) = getInfo i
file' = case filePathPrintLength of
FullPath -> file
ShortPath -> takeFileName file
in file' ++ ":" ++ show line ++ ":" ++ show column
FullPath -> file
ShortPath -> takeFileName file
in file' ++ ":" ++ show line ++ ":" ++ show column
-- | Use an Info to generate a type variable name.
makeTypeVariableNameFromInfo :: Maybe Info -> String

636
src/InitialTypes.hs
View File

@ -2,20 +2,20 @@ module InitialTypes where
import Control.Monad.State
import qualified Data.Map as Map
import Types
import Obj
import Util
import TypeError
import Lookup
import Info
import Lookup
import Obj
import TypeError
import Types
import Util
-- | Create a fresh type variable (eg. 'VarTy t0', 'VarTy t1', etc...)
genVarTyWithPrefix :: String -> State Integer Ty
genVarTyWithPrefix prefix =
do x <- get
put (x + 1)
pure (VarTy (prefix ++ show x))
do
x <- get
put (x + 1)
pure (VarTy (prefix ++ show x))
genVarTy :: State Integer Ty
genVarTy = genVarTyWithPrefix "t"
@ -29,34 +29,38 @@ genVarTys n = replicateM n genVarTy
-- Example: (t0, t1, t1) -> t0
-- becomes: (r2, r3, r3) -> r2
renameVarTys :: Ty -> State Integer Ty
renameVarTys rootType = do n <- get
let (result, (n', _)) = runState (rename rootType) (n, Map.empty)
put n'
pure result
renameVarTys rootType = do
n <- get
let (result, (n', _)) = runState (rename rootType) (n, Map.empty)
put n'
pure result
where
rename :: Ty -> State (Integer, Map.Map String Ty) Ty
rename (FuncTy argTys retTy ltTy) = do ltTy' <- rename ltTy
argTys' <- mapM rename argTys
retTy' <- rename retTy
pure (FuncTy argTys' retTy' ltTy')
rename (VarTy v) = do (n, mappings) <- get
case Map.lookup v mappings of
Just found -> pure found
Nothing -> do let varTy = VarTy ("r" ++ show n)
newMappings = Map.insert v varTy mappings
put (n + 1, newMappings)
pure varTy
rename (StructTy name tyArgs) = do tyArgs' <- mapM rename tyArgs
name' <- rename name
pure (StructTy name' tyArgs')
rename (PointerTy x) = do x' <- rename x
pure (PointerTy x')
rename (RefTy x lt) = do x' <- rename x
lt' <- rename lt
pure (RefTy x' lt')
rename (FuncTy argTys retTy ltTy) = do
ltTy' <- rename ltTy
argTys' <- mapM rename argTys
retTy' <- rename retTy
pure (FuncTy argTys' retTy' ltTy')
rename (VarTy v) = do
(n, mappings) <- get
case Map.lookup v mappings of
Just found -> pure found
Nothing -> do
let varTy = VarTy ("r" ++ show n)
newMappings = Map.insert v varTy mappings
put (n + 1, newMappings)
pure varTy
rename (StructTy name tyArgs) = do
tyArgs' <- mapM rename tyArgs
name' <- rename name
pure (StructTy name' tyArgs')
rename (PointerTy x) = do
x' <- rename x
pure (PointerTy x')
rename (RefTy x lt) = do
x' <- rename x
lt' <- rename lt
pure (RefTy x' lt')
rename x = pure x
-- | Adds initial types to a s-expression and all its sub-nodes.
@ -66,325 +70,352 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
where
visit :: Env -> XObj -> State Integer (Either TypeError XObj)
visit env xobj = case xobjObj xobj of
(Num t _) -> pure (Right (xobj { xobjTy = Just t }))
(Bol _) -> pure (Right (xobj { xobjTy = Just BoolTy }))
(Str _) -> do lt <- genVarTy
pure (Right (xobj { xobjTy = Just (RefTy StringTy lt) }))
(Pattern _) -> do lt <- genVarTy
pure (Right (xobj { xobjTy = Just (RefTy PatternTy lt) }))
(Chr _) -> pure (Right (xobj { xobjTy = Just CharTy }))
Break -> pure (Right (xobj { xobjTy = Just (FuncTy [] UnitTy StaticLifetimeTy)}))
(Command _) -> pure (Right (xobj { xobjTy = Just DynamicTy }))
(Lst _) -> visitList env xobj
(Arr _) -> visitArray env xobj
(StaticArr _) -> visitStaticArray env xobj
(Dict _) -> visitDictionary env xobj
(Sym symPath _) -> visitSymbol env xobj symPath
(MultiSym _ paths) -> visitMultiSym env xobj paths
(InterfaceSym _) -> visitInterfaceSym env xobj
e@(Defn _) -> pure (Left (InvalidObj e xobj))
Def -> pure (Left (InvalidObj Def xobj))
DefDynamic -> pure (Left (InvalidObj DefDynamic xobj))
e@(Fn _ _) -> pure (Left (InvalidObj e xobj))
Let -> pure (Left (InvalidObj Let xobj))
If -> pure (Left (InvalidObj If xobj))
While -> pure (Left (InvalidObj While xobj))
Do -> pure (Left (InvalidObj Do xobj))
(Mod _) -> pure (Left (InvalidObj If xobj))
e@(Deftype _) -> pure (Left (InvalidObj e xobj))
e@(External _) -> pure (Left (InvalidObj e xobj))
e@(ExternalType _) -> pure (Left (InvalidObj e xobj))
e@(Deftemplate _) -> pure (Left (InvalidObj e xobj))
e@(Instantiate _) -> pure (Left (InvalidObj e xobj))
e@(Defalias _) -> pure (Left (InvalidObj e xobj))
Address -> pure (Left (InvalidObj Address xobj))
SetBang -> pure (Left (InvalidObj SetBang xobj))
Macro -> pure (Left (InvalidObj Macro xobj))
The -> pure (Left (InvalidObj The xobj))
Dynamic -> pure (Left (InvalidObj Dynamic xobj))
Ref -> pure (Left (InvalidObj Ref xobj))
Deref -> pure (Left (InvalidObj Deref xobj))
With -> pure (Left (InvalidObj With xobj))
-- catchall case for exhaustive patterns
unknown -> pure (Left (InvalidObj unknown xobj))
(Num t _) -> pure (Right (xobj {xobjTy = Just t}))
(Bol _) -> pure (Right (xobj {xobjTy = Just BoolTy}))
(Str _) -> do
lt <- genVarTy
pure (Right (xobj {xobjTy = Just (RefTy StringTy lt)}))
(Pattern _) -> do
lt <- genVarTy
pure (Right (xobj {xobjTy = Just (RefTy PatternTy lt)}))
(Chr _) -> pure (Right (xobj {xobjTy = Just CharTy}))
Break -> pure (Right (xobj {xobjTy = Just (FuncTy [] UnitTy StaticLifetimeTy)}))
(Command _) -> pure (Right (xobj {xobjTy = Just DynamicTy}))
(Lst _) -> visitList env xobj
(Arr _) -> visitArray env xobj
(StaticArr _) -> visitStaticArray env xobj
(Dict _) -> visitDictionary env xobj
(Sym symPath _) -> visitSymbol env xobj symPath
(MultiSym _ paths) -> visitMultiSym env xobj paths
(InterfaceSym _) -> visitInterfaceSym env xobj
e@(Defn _) -> pure (Left (InvalidObj e xobj))
Def -> pure (Left (InvalidObj Def xobj))
DefDynamic -> pure (Left (InvalidObj DefDynamic xobj))
e@(Fn _ _) -> pure (Left (InvalidObj e xobj))
Let -> pure (Left (InvalidObj Let xobj))
If -> pure (Left (InvalidObj If xobj))
While -> pure (Left (InvalidObj While xobj))
Do -> pure (Left (InvalidObj Do xobj))
(Mod _) -> pure (Left (InvalidObj If xobj))
e@(Deftype _) -> pure (Left (InvalidObj e xobj))
e@(External _) -> pure (Left (InvalidObj e xobj))
e@(ExternalType _) -> pure (Left (InvalidObj e xobj))
e@(Deftemplate _) -> pure (Left (InvalidObj e xobj))
e@(Instantiate _) -> pure (Left (InvalidObj e xobj))
e@(Defalias _) -> pure (Left (InvalidObj e xobj))
Address -> pure (Left (InvalidObj Address xobj))
SetBang -> pure (Left (InvalidObj SetBang xobj))
Macro -> pure (Left (InvalidObj Macro xobj))
The -> pure (Left (InvalidObj The xobj))
Dynamic -> pure (Left (InvalidObj Dynamic xobj))
Ref -> pure (Left (InvalidObj Ref xobj))
Deref -> pure (Left (InvalidObj Deref xobj))
With -> pure (Left (InvalidObj With xobj))
-- catchall case for exhaustive patterns
unknown -> pure (Left (InvalidObj unknown xobj))
visitSymbol :: Env -> XObj -> SymPath -> State Integer (Either TypeError XObj)
visitSymbol _ xobj@(XObj (Sym _ LookupRecursive) _ _) _ =
-- Recursive lookups are left untouched (this avoids problems with looking up the thing they're referring to)
do freshTy <- genVarTy
pure (Right xobj { xobjTy = Just freshTy })
do
freshTy <- genVarTy
pure (Right xobj {xobjTy = Just freshTy})
visitSymbol env xobj symPath =
case symPath of
-- Symbols with leading ? are 'holes'.
SymPath _ name@('?' : _) -> pure (Right (xobj { xobjTy = Just (VarTy name) }))
SymPath _ name@('?' : _) -> pure (Right (xobj {xobjTy = Just (VarTy name)}))
SymPath _ (':' : _) -> pure (Left (LeadingColon xobj))
_ ->
case lookupInEnv symPath env of
Just (foundEnv, binder) ->
case xobjTy (binderXObj binder) of
-- Don't rename internal symbols like parameters etc!
Just theType | envIsExternal foundEnv -> do renamed <- renameVarTys theType
pure (Right (xobj { xobjTy = Just renamed }))
| otherwise -> pure (Right (xobj { xobjTy = Just theType }))
Just theType
| envIsExternal foundEnv -> do
renamed <- renameVarTys theType
pure (Right (xobj {xobjTy = Just renamed}))
| otherwise -> pure (Right (xobj {xobjTy = Just theType}))
Nothing -> pure (Left (SymbolMissingType xobj foundEnv))
Nothing -> pure (Left (SymbolNotDefined symPath xobj env)) -- Gives the error message "Trying to refer to an undefined symbol ..."
visitMultiSym :: Env -> XObj -> [SymPath] -> State Integer (Either TypeError XObj)
visitMultiSym _ xobj@(XObj (MultiSym _ _) _ _) _ =
do freshTy <- genVarTy
pure (Right xobj { xobjTy = Just freshTy })
do
freshTy <- genVarTy
pure (Right xobj {xobjTy = Just freshTy})
visitInterfaceSym :: Env -> XObj -> State Integer (Either TypeError XObj)
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)
Nothing -> genVarTy
pure (Right xobj { xobjTy = Just freshTy })
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)
Nothing -> genVarTy
pure (Right xobj {xobjTy = Just freshTy})
visitArray :: Env -> XObj -> State Integer (Either TypeError XObj)
visitArray env (XObj (Arr xobjs) i _) =
do visited <- mapM (visit env) xobjs
arrayVarTy <- genVarTy
pure $ do okVisited <- sequence visited
Right (XObj (Arr okVisited) i (Just (StructTy (ConcreteNameTy "Array") [arrayVarTy])))
do
visited <- mapM (visit env) xobjs
arrayVarTy <- genVarTy
pure $ do
okVisited <- sequence visited
Right (XObj (Arr okVisited) i (Just (StructTy (ConcreteNameTy "Array") [arrayVarTy])))
visitArray _ _ = error "The function 'visitArray' only accepts XObj:s with arrays in them."
visitStaticArray :: Env -> XObj -> State Integer (Either TypeError XObj)
visitStaticArray env (XObj (StaticArr xobjs) i _) =
do visited <- mapM (visit env) xobjs
arrayVarTy <- genVarTy
lt <- genVarTy
pure $ do okVisited <- sequence visited
Right (XObj (StaticArr okVisited) i (Just (RefTy (StructTy (ConcreteNameTy "StaticArray") [arrayVarTy]) lt)))
do
visited <- mapM (visit env) xobjs
arrayVarTy <- genVarTy
lt <- genVarTy
pure $ do
okVisited <- sequence visited
Right (XObj (StaticArr okVisited) i (Just (RefTy (StructTy (ConcreteNameTy "StaticArray") [arrayVarTy]) lt)))
visitStaticArray _ _ = error "The function 'visitStaticArray' only accepts XObj:s with arrays in them."
visitDictionary :: Env -> XObj -> State Integer (Either TypeError XObj)
visitDictionary env (XObj (Dict xobjs) i _) =
do visited <- mapM (visit env) xobjs
arrayVarTy <- genVarTy
pure $ do okVisited <- sequence visited
Right (XObj (Dict okVisited) i (Just (StructTy (ConcreteNameTy "Dictionary") [arrayVarTy])))
do
visited <- mapM (visit env) xobjs
arrayVarTy <- genVarTy
pure $ do
okVisited <- sequence visited
Right (XObj (Dict okVisited) i (Just (StructTy (ConcreteNameTy "Dictionary") [arrayVarTy])))
visitDictionary _ _ = error "The function 'visitArray' only accepts XObj:s with dictionaries in them."
getTys env argList =
do argTypes <- genVarTys (length argList)
returnType <- genVarTy
funcScopeEnv <- extendEnvWithParamList env argList
pure (argTypes, returnType, funcScopeEnv)
do
argTypes <- genVarTys (length argList)
returnType <- genVarTy
funcScopeEnv <- extendEnvWithParamList env argList
pure (argTypes, returnType, funcScopeEnv)
visitList :: Env -> XObj -> State Integer (Either TypeError XObj)
visitList env xobj@(XObj (Lst xobjs) i _) =
case xobjs of
-- Defn
[defn@(XObj (Defn _) _ _), nameSymbol@(XObj (Sym (SymPath _ name) _) _ _), XObj (Arr argList) argsi argst, body] ->
do (argTypes, returnType, funcScopeEnv) <- getTys env argList
let funcTy = Just (FuncTy argTypes returnType StaticLifetimeTy)
typedNameSymbol = nameSymbol { xobjTy = funcTy }
-- TODO! After the introduction of 'LookupRecursive' this env shouldn't be needed anymore? (but it is for some reason...)
envWithSelf = extendEnv funcScopeEnv name typedNameSymbol
visitedBody <- visit envWithSelf body
visitedArgs <- mapM (visit envWithSelf) argList
pure $ do okBody <- visitedBody
okArgs <- sequence visitedArgs
pure (XObj (Lst [defn, nameSymbol, XObj (Arr okArgs) argsi argst, okBody]) i funcTy)
do
(argTypes, returnType, funcScopeEnv) <- getTys env argList
let funcTy = Just (FuncTy argTypes returnType StaticLifetimeTy)
typedNameSymbol = nameSymbol {xobjTy = funcTy}
-- TODO! After the introduction of 'LookupRecursive' this env shouldn't be needed anymore? (but it is for some reason...)
envWithSelf = extendEnv funcScopeEnv name typedNameSymbol
visitedBody <- visit envWithSelf body
visitedArgs <- mapM (visit envWithSelf) argList
pure $ do
okBody <- visitedBody
okArgs <- sequence visitedArgs
pure (XObj (Lst [defn, nameSymbol, XObj (Arr okArgs) argsi argst, okBody]) i funcTy)
[(XObj (Defn _) _ _), XObj (Sym _ _) _ _, XObj (Arr _) _ _] -> pure (Left (NoFormsInBody xobj))
XObj defn@(Defn _) _ _ : _ -> pure (Left (InvalidObj defn xobj))
XObj defn@(Defn _) _ _ : _ -> pure (Left (InvalidObj defn xobj))
-- Fn
[fn@(XObj (Fn _ _) _ _), XObj (Arr argList) argsi argst, body] ->
do (argTypes, returnType, funcScopeEnv) <- getTys env argList
lt <- genVarTy
let funcTy = Just (FuncTy argTypes returnType lt)
visitedBody <- visit funcScopeEnv body
visitedArgs <- mapM (visit funcScopeEnv) argList
pure $ do okBody <- visitedBody
okArgs <- sequence visitedArgs
let final = XObj (Lst [fn, XObj (Arr okArgs) argsi argst, okBody]) i funcTy
pure final --(trace ("FINAL: " ++ show final) final)
[XObj (Fn _ _ ) _ _, XObj (Arr _) _ _] -> pure (Left (NoFormsInBody xobj)) -- TODO: Special error message for lambdas needed?
XObj fn@(Fn _ _) _ _ : _ -> pure (Left (InvalidObj fn xobj))
do
(argTypes, returnType, funcScopeEnv) <- getTys env argList
lt <- genVarTy
let funcTy = Just (FuncTy argTypes returnType lt)
visitedBody <- visit funcScopeEnv body
visitedArgs <- mapM (visit funcScopeEnv) argList
pure $ do
okBody <- visitedBody
okArgs <- sequence visitedArgs
let final = XObj (Lst [fn, XObj (Arr okArgs) argsi argst, okBody]) i funcTy
pure final --(trace ("FINAL: " ++ show final) final)
[XObj (Fn _ _) _ _, XObj (Arr _) _ _] -> pure (Left (NoFormsInBody xobj)) -- TODO: Special error message for lambdas needed?
XObj fn@(Fn _ _) _ _ : _ -> pure (Left (InvalidObj fn xobj))
-- Def
[def@(XObj Def _ _), nameSymbol, expression]->
do definitionType <- genVarTy
visitedExpr <- visit env expression
pure $ do okExpr <- visitedExpr
pure (XObj (Lst [def, nameSymbol, okExpr]) i (Just definitionType))
[def@(XObj Def _ _), nameSymbol, expression] ->
do
definitionType <- genVarTy
visitedExpr <- visit env expression
pure $ do
okExpr <- visitedExpr
pure (XObj (Lst [def, nameSymbol, okExpr]) i (Just definitionType))
XObj Def _ _ : _ -> pure (Left (InvalidObj Def xobj))
-- DefDynamic
[def@(XObj DefDynamic _ _), nameSymbol, expression] ->
pure $ pure (XObj (Lst [def, nameSymbol, expression]) i (Just DynamicTy))
XObj DefDynamic _ _ : _ -> pure (Left (InvalidObj Def xobj))
-- Let binding
[letExpr@(XObj Let _ _), XObj (Arr bindings) bindi bindt, body] ->
do wholeExprType <- genVarTy
letScopeEnv <- extendEnvWithLetBindings env bindings
case letScopeEnv of
Right okLetScopeEnv ->
do visitedBindings <- mapM (visit okLetScopeEnv) bindings
visitedBody <- visit okLetScopeEnv body
pure $ do okBindings <- sequence visitedBindings
case getDuplicate [] okBindings of
Just dup -> Left (DuplicateBinding dup)
Nothing -> do
okBody <- visitedBody
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) _) _ _):_:xs) =
if x `elem` names then Just o else getDuplicate (x:names) xs
do
wholeExprType <- genVarTy
letScopeEnv <- extendEnvWithLetBindings env bindings
case letScopeEnv of
Right okLetScopeEnv ->
do
visitedBindings <- mapM (visit okLetScopeEnv) bindings
visitedBody <- visit okLetScopeEnv body
pure $ do
okBindings <- sequence visitedBindings
case getDuplicate [] okBindings of
Just dup -> Left (DuplicateBinding dup)
Nothing -> do
okBody <- visitedBody
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) _) _ _) : _ : xs) =
if x `elem` names then Just o else getDuplicate (x : names) xs
[XObj Let _ _, XObj (Arr _) _ _] ->
pure (Left (NoFormsInBody xobj))
XObj Let _ _ : XObj (Arr _) _ _ : _ ->
pure (Left (TooManyFormsInBody xobj))
XObj Let _ _ : _ ->
pure (Left (InvalidObj Let xobj))
-- If
[ifExpr@(XObj If _ _), expr, ifTrue, ifFalse] ->
do visitedExpr <- visit env expr
visitedTrue <- visit env ifTrue
visitedFalse <- visit env ifFalse
returnType <- genVarTy
pure $ do okExpr <- visitedExpr
okTrue <- visitedTrue
okFalse <- visitedFalse
pure (XObj (Lst [ifExpr
,okExpr
,okTrue
,okFalse
]) i (Just returnType))
do
visitedExpr <- visit env expr
visitedTrue <- visit env ifTrue
visitedFalse <- visit env ifFalse
returnType <- genVarTy
pure $ do
okExpr <- visitedExpr
okTrue <- visitedTrue
okFalse <- visitedFalse
pure
( XObj
( Lst
[ ifExpr,
okExpr,
okTrue,
okFalse
]
)
i
(Just returnType)
)
XObj If _ _ : _ -> pure (Left (InvalidObj If xobj))
-- Match
matchExpr@(XObj (Match _) _ _) : expr : cases ->
do visitedExpr <- visit env expr
visitedCases <- sequence <$>
mapM (\(lhs, rhs) -> do let lhs' = uniquifyWildcardNames (helpWithParens lhs) -- Add parens if missing
env' <- extendEnvWithCaseMatch env lhs'
visitedLhs <- visit env' lhs'
visitedRhs <- visit env' rhs
pure $ do okLhs <- visitedLhs
okRhs <- visitedRhs
pure (okLhs, okRhs))
(pairwise cases)
returnType <- genVarTy
pure $ do okExpr <- visitedExpr
okCases <- visitedCases
let okCasesConcatenated = concatMap (\(a, b) -> [a, b]) okCases
pure (XObj (Lst ([matchExpr, okExpr] ++ okCasesConcatenated))
i (Just returnType))
do
visitedExpr <- visit env expr
visitedCases <-
sequence
<$> mapM
( \(lhs, rhs) -> do
let lhs' = uniquifyWildcardNames (helpWithParens lhs) -- Add parens if missing
env' <- extendEnvWithCaseMatch env lhs'
visitedLhs <- visit env' lhs'
visitedRhs <- visit env' rhs
pure $ do
okLhs <- visitedLhs
okRhs <- visitedRhs
pure (okLhs, okRhs)
)
(pairwise cases)
returnType <- genVarTy
pure $ do
okExpr <- visitedExpr
okCases <- visitedCases
let okCasesConcatenated = concatMap (\(a, b) -> [a, b]) okCases
pure
( XObj
(Lst ([matchExpr, okExpr] ++ okCasesConcatenated))
i
(Just returnType)
)
XObj (Match m) _ _ : _ -> pure (Left (InvalidObj (Match m) xobj))
-- While (always return Unit)
[whileExpr@(XObj While _ _), expr, body] ->
do visitedExpr <- visit env expr
visitedBody <- visit env body
pure $ do okExpr <- visitedExpr
okBody <- visitedBody
pure (XObj (Lst [whileExpr, okExpr, okBody]) i (Just UnitTy))
do
visitedExpr <- visit env expr
visitedBody <- visit env body
pure $ do
okExpr <- visitedExpr
okBody <- visitedBody
pure (XObj (Lst [whileExpr, okExpr, okBody]) i (Just UnitTy))
[XObj While _ _, _] ->
pure (Left (NoFormsInBody xobj))
XObj While _ _ : _ ->
pure (Left (TooManyFormsInBody xobj))
-- Do
doExpr@(XObj Do _ _) : expressions ->
do t <- genVarTy
visitedExpressions <- fmap sequence (mapM (visit env) expressions)
pure $ do okExpressions <- visitedExpressions
pure (XObj (Lst (doExpr : okExpressions)) i (Just t))
do
t <- genVarTy
visitedExpressions <- fmap sequence (mapM (visit env) expressions)
pure $ do
okExpressions <- visitedExpressions
pure (XObj (Lst (doExpr : okExpressions)) i (Just t))
-- Address
[addressExpr@(XObj Address _ _), value] ->
do visitedValue <- visit env value
pure $ do okValue <- visitedValue
let Just t' = xobjTy okValue
pure (XObj (Lst [addressExpr, okValue]) i (Just (PointerTy t')))
do
visitedValue <- visit env value
pure $ do
okValue <- visitedValue
let Just t' = xobjTy okValue
pure (XObj (Lst [addressExpr, okValue]) i (Just (PointerTy t')))
-- Set!
[setExpr@(XObj SetBang _ _), variable, value] ->
do visitedVariable <- visit env variable
visitedValue <- visit env value
pure $ do okVariable <- visitedVariable
okValue <- visitedValue
pure (XObj (Lst [setExpr, okVariable, okValue]) i (Just UnitTy))
do
visitedVariable <- visit env variable
visitedValue <- visit env value
pure $ do
okVariable <- visitedVariable
okValue <- visitedValue
pure (XObj (Lst [setExpr, okVariable, okValue]) i (Just UnitTy))
XObj SetBang _ _ : _ -> pure (Left (InvalidObj SetBang xobj))
-- The
[theExpr@(XObj The _ _), typeXObj, value] ->
do visitedValue <- visit env value
pure $ do okValue <- visitedValue
case xobjToTy typeXObj of
Just okType -> pure (XObj (Lst [theExpr, typeXObj, okValue]) i (Just okType))
Nothing -> Left (NotAType typeXObj)
do
visitedValue <- visit env value
pure $ do
okValue <- visitedValue
case xobjToTy typeXObj of
Just okType -> pure (XObj (Lst [theExpr, typeXObj, okValue]) i (Just okType))
Nothing -> Left (NotAType typeXObj)
XObj The _ _ : _ -> pure (Left (InvalidObj The xobj))
-- Ref
[refExpr@(XObj Ref _ _), value] ->
do visitedValue <- visit env value
lt <- case value of -- This is to not get lifetime errors when using globals. TODO: Is there a better way?!
XObj (Sym _ (LookupGlobal _ _)) _ _ -> pure StaticLifetimeTy
_ | isLiteral value -> pure StaticLifetimeTy
| otherwise -> genVarTy
pure $ do okValue <- visitedValue
let Just valueTy = xobjTy okValue
pure (XObj (Lst [refExpr, okValue]) i (Just (RefTy valueTy lt)))
do
visitedValue <- visit env value
lt <- case value of -- This is to not get lifetime errors when using globals. TODO: Is there a better way?!
XObj (Sym _ (LookupGlobal _ _)) _ _ -> pure StaticLifetimeTy
_
| isLiteral value -> pure StaticLifetimeTy
| otherwise -> genVarTy
pure $ do
okValue <- visitedValue
let Just valueTy = xobjTy okValue
pure (XObj (Lst [refExpr, okValue]) i (Just (RefTy valueTy lt)))
-- Deref (error!)
[XObj Deref _ _, _] ->
pure (Left (CantUseDerefOutsideFunctionApplication xobj))
-- Function application with Deref
XObj (Lst [deref@(XObj Deref _ _), func]) xi _ : args ->
-- TODO: Remove code duplication (taken from function application below)
do t <- genVarTy
derefTy <- genVarTy
visitedFunc <- visit env func
visitedArgs <- fmap sequence (mapM (visit env) args)
pure $ do okFunc <- visitedFunc
okArgs <- visitedArgs
pure (XObj (Lst (XObj (Lst [deref, okFunc]) xi (Just derefTy) : okArgs)) i (Just t))
do
t <- genVarTy
derefTy <- genVarTy
visitedFunc <- visit env func
visitedArgs <- fmap sequence (mapM (visit env) args)
pure $ do
okFunc <- visitedFunc
okArgs <- visitedArgs
pure (XObj (Lst (XObj (Lst [deref, okFunc]) xi (Just derefTy) : okArgs)) i (Just t))
-- Function application
func : args ->
do t <- genVarTy
visitedFunc <- visit env func
visitedArgs <- fmap sequence (mapM (visit env) args)
pure $ do okFunc <- visitedFunc
okArgs <- visitedArgs
pure (XObj (Lst (okFunc : okArgs)) i (Just t))
do
t <- genVarTy
visitedFunc <- visit env func
visitedArgs <- fmap sequence (mapM (visit env) args)
pure $ do
okFunc <- visitedFunc
okArgs <- visitedArgs
pure (XObj (Lst (okFunc : okArgs)) i (Just t))
-- Empty list
[] -> pure (Right xobj { xobjTy = Just UnitTy })
[] -> pure (Right xobj {xobjTy = Just UnitTy})
visitList _ _ = error "Must match on list!"
extendEnvWithLetBindings :: Env -> [XObj] -> State Integer (Either TypeError Env)
extendEnvWithLetBindings env xobjs =
let pairs = pairwise xobjs
emptyInnerEnv = Env { envBindings = Map.fromList []
, envParent = Just env
, envModuleName = Nothing
, envUseModules = []
, envMode = InternalEnv
, envFunctionNestingLevel = envFunctionNestingLevel env
}
-- Need to fold (rather than map) to make the previous bindings accessible to the later ones, i.e. (let [a 100 b a] ...)
in foldM createBinderForLetPair (Right emptyInnerEnv) pairs
emptyInnerEnv =
Env
{ envBindings = Map.fromList [],
envParent = Just env,
envModuleName = Nothing,
envUseModules = [],
envMode = InternalEnv,
envFunctionNestingLevel = envFunctionNestingLevel env
}
in -- Need to fold (rather than map) to make the previous bindings accessible to the later ones, i.e. (let [a 100 b a] ...)
foldM createBinderForLetPair (Right emptyInnerEnv) pairs
where
createBinderForLetPair :: Either TypeError Env -> (XObj, XObj) -> State Integer (Either TypeError Env)
createBinderForLetPair envOrErr (sym, expr) =
@ -393,63 +424,70 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
Right env' ->
case xobjObj sym of
(Sym (SymPath _ name) _) ->
do visited <- visit env' expr
pure (envAddBinding env' name . Binder emptyMeta <$> visited)
do
visited <- visit env' expr
pure (envAddBinding env' name . Binder emptyMeta <$> visited)
_ -> pure (Left (InvalidLetBinding xobjs (sym, expr)))
extendEnvWithParamList :: Env -> [XObj] -> State Integer Env
extendEnvWithParamList env xobjs =
do binders <- mapM createBinderForParam xobjs
pure Env { envBindings = Map.fromList binders
, envParent = Just env
, envModuleName = Nothing
, envUseModules = []
, envMode = InternalEnv
, envFunctionNestingLevel = envFunctionNestingLevel env
}
do
binders <- mapM createBinderForParam xobjs
pure
Env
{ envBindings = Map.fromList binders,
envParent = Just env,
envModuleName = Nothing,
envUseModules = [],
envMode = InternalEnv,
envFunctionNestingLevel = envFunctionNestingLevel env
}
where
createBinderForParam :: XObj -> State Integer (String, Binder)
createBinderForParam xobj =
case xobjObj xobj of
(Sym (SymPath _ name) _) ->
do t <- genVarTy
let xobjWithTy = xobj { xobjTy = Just t }
pure (name, Binder emptyMeta xobjWithTy)
do
t <- genVarTy
let xobjWithTy = xobj {xobjTy = Just t}
pure (name, Binder emptyMeta xobjWithTy)
_ -> error "Can't create binder for non-symbol parameter."
extendEnvWithCaseMatch :: Env -> XObj -> State Integer Env
extendEnvWithCaseMatch env caseRoot =
do binders <- createBindersForCaseVariable caseRoot
pure Env { envBindings = Map.fromList binders
, envParent = Just env
, envModuleName = Nothing
, envUseModules = []
, envMode = InternalEnv
, envFunctionNestingLevel = envFunctionNestingLevel env
}
do
binders <- createBindersForCaseVariable caseRoot
pure
Env
{ envBindings = Map.fromList binders,
envParent = Just env,
envModuleName = Nothing,
envUseModules = [],
envMode = InternalEnv,
envFunctionNestingLevel = envFunctionNestingLevel env
}
where
createBindersForCaseVariable :: XObj -> State Integer [(String, Binder)]
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 (Lst lst) _ _) = do binders <- mapM createBindersForCaseVariable lst
pure (concat binders)
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)]
createBinderInternal xobj name =
if isVarName name
-- A variable that will bind to something:
then do freshTy <- genVarTy
pure [(name, Binder emptyMeta xobj { xobjTy = Just freshTy })]
-- Tags for the sumtypes won't bind to anything:
else pure []
then-- A variable that will bind to something:
do
freshTy <- genVarTy
pure [(name, Binder emptyMeta xobj {xobjTy = Just freshTy})]
else-- Tags for the sumtypes won't bind to anything:
pure []
uniquifyWildcardNames :: XObj -> XObj
uniquifyWildcardNames (XObj (Sym (SymPath [] "_") mode) (Just i) t) =
let uniqueName = "wildcard_" ++ show (infoIdentifier i)
in XObj (Sym (SymPath [] uniqueName) mode) (Just i) t
in XObj (Sym (SymPath [] uniqueName) mode) (Just i) t
uniquifyWildcardNames (XObj (Lst xobjs) i t) =
XObj (Lst (map uniquifyWildcardNames xobjs)) i t
uniquifyWildcardNames (XObj (Arr xobjs) i t) =

95
src/Interfaces.hs
View File

@ -2,36 +2,48 @@
-- Interface registration involves associating some concrete form, e.g. a defn with an interface.
-- Registered forms may be used wherever the interface is called.
-- Registrations are stored w/ the interface in the context type environment.
module Interfaces (registerInInterfaceIfNeeded,
registerInInterface,
retroactivelyRegisterInInterface) where
import Data.Either (isRight)
module Interfaces
( registerInInterfaceIfNeeded,
registerInInterface,
retroactivelyRegisterInInterface,
)
where
import ColorText
import Obj
import Constraints
import Data.Either (isRight)
import Data.List (foldl')
import Lookup
import Obj
import Types
import Util
import Constraints
import Data.List (foldl')
data InterfaceError = KindMismatch SymPath Ty Ty
| TypeMismatch SymPath Ty Ty
| NonInterface SymPath
data InterfaceError
= KindMismatch SymPath Ty Ty
| TypeMismatch SymPath Ty Ty
| NonInterface SymPath
instance Show InterfaceError where
show (KindMismatch path definitionSignature interfaceSignature) =
labelStr "INTERFACE ERROR"
(show path ++ ":" ++ " One or more types in the interface implementation " ++
show definitionSignature ++ " have kinds that do not match the kinds of the types in the interface signature " ++
show interfaceSignature ++ "\n" ++ "Types of the form (f a) must be matched by constructor types such as (Maybe a)")
labelStr
"INTERFACE ERROR"
( show path ++ ":" ++ " One or more types in the interface implementation "
++ show definitionSignature
++ " have kinds that do not match the kinds of the types in the interface signature "
++ show interfaceSignature
++ "\n"
++ "Types of the form (f a) must be matched by constructor types such as (Maybe a)"
)
show (TypeMismatch path definitionSignature interfaceSignature) =
labelStr "INTERFACE ERROR"
(show path ++ " : " ++ show definitionSignature ++
" doesn't match the interface signature " ++ show interfaceSignature)
labelStr
"INTERFACE ERROR"
( show path ++ " : " ++ show definitionSignature
++ " doesn't match the interface signature "
++ show interfaceSignature
)
show (NonInterface path) =
labelStr "INTERFACE ERROR"
labelStr
"INTERFACE ERROR"
(show path ++ "Cant' implement the non-interface `" ++ show path ++ "`")
-- TODO: This is currently called once outside of this module--try to remove that call and make this internal.
@ -39,19 +51,22 @@ instance Show InterfaceError where
registerInInterfaceIfNeeded :: Context -> SymPath -> SymPath -> Ty -> Either String Context
registerInInterfaceIfNeeded ctx path@(SymPath _ _) interface@(SymPath [] name) definitionSignature =
maybe (pure ctx) (typeCheck . snd) (lookupInEnv interface typeEnv)
where typeEnv = getTypeEnv (contextTypeEnv ctx)
typeCheck binder = case binder of
Binder _ (XObj (Lst [inter@(XObj (Interface interfaceSignature paths) ii it), isym]) i t) ->
if checkKinds interfaceSignature definitionSignature
-- N.B. the xobjs aren't important here--we only care about types,
-- thus we pass inter to all three xobj positions.
then if isRight $ solve [Constraint interfaceSignature definitionSignature inter inter inter OrdInterfaceImpl]
then let updatedInterface = XObj (Lst [XObj (Interface interfaceSignature (addIfNotPresent path paths)) ii it, isym]) i t
in Right $ ctx { contextTypeEnv = TypeEnv (extendEnv typeEnv name updatedInterface) }
else Left (show $ TypeMismatch path definitionSignature interfaceSignature)
else Left (show $ KindMismatch path definitionSignature interfaceSignature)
_ ->
Left (show $ NonInterface interface)
where
typeEnv = getTypeEnv (contextTypeEnv ctx)
typeCheck binder = case binder of
Binder _ (XObj (Lst [inter@(XObj (Interface interfaceSignature paths) ii it), isym]) i t) ->
if checkKinds interfaceSignature definitionSignature
then-- N.B. the xobjs aren't important here--we only care about types,
-- thus we pass inter to all three xobj positions.
if isRight $ solve [Constraint interfaceSignature definitionSignature inter inter inter OrdInterfaceImpl]
then
let updatedInterface = XObj (Lst [XObj (Interface interfaceSignature (addIfNotPresent path paths)) ii it, isym]) i t
in Right $ ctx {contextTypeEnv = TypeEnv (extendEnv typeEnv name updatedInterface)}
else Left (show $ TypeMismatch path definitionSignature interfaceSignature)
else Left (show $ KindMismatch path definitionSignature interfaceSignature)
_ ->
Left (show $ NonInterface interface)
-- | Given an XObj and an interface path, ensure that the form is
-- registered with the interface.
@ -67,10 +82,10 @@ registerInInterface ctx xobj interface =
XObj (Lst [XObj Def _ _, XObj (Sym path _) _ _, _]) _ (Just t) ->
-- Global variables can also be part of an interface
registerInInterfaceIfNeeded ctx path interface t
-- So can externals!
-- So can externals!
XObj (Lst [XObj (External _) _ _, XObj (Sym path _) _ _, _]) _ (Just t) ->
registerInInterfaceIfNeeded ctx path interface t
-- And instantiated/auto-derived type functions! (e.g. Pair.a)
-- And instantiated/auto-derived type functions! (e.g. Pair.a)
XObj (Lst [XObj (Instantiate _) _ _, XObj (Sym path _) _ _]) _ (Just t) ->
registerInInterfaceIfNeeded ctx path interface t
_ -> pure ctx
@ -81,8 +96,10 @@ retroactivelyRegisterInInterface :: Context -> SymPath -> Context
retroactivelyRegisterInInterface ctx interface@(SymPath _ _) =
-- TODO: Don't use error here?
either (\e -> error e) id resultCtx
where env = contextGlobalEnv ctx
impls = recursiveLookupAll interface lookupImplementations env
resultCtx = foldl' folder (Right ctx) impls
folder ctx' binder = either Left register' ctx'
where register' ok = registerInInterface ok (binderXObj binder) interface
where
env = contextGlobalEnv ctx
impls = recursiveLookupAll interface lookupImplementations env
resultCtx = foldl' folder (Right ctx) impls
folder ctx' binder = either Left register' ctx'
where
register' ok = registerInInterface ok (binderXObj binder) interface

193
src/Lookup.hs
View File

@ -3,11 +3,10 @@ module Lookup where
import Data.List (foldl')
import qualified Data.Map as Map
import Data.Maybe (mapMaybe)
import Text.EditDistance (defaultEditCosts, levenshteinDistance)
import Types
import Obj
import qualified Meta
import Obj
import Text.EditDistance (defaultEditCosts, levenshteinDistance)
import Types
-- | The type of generic lookup functions.
type LookupFunc a = a -> Env -> [Binder]
@ -18,8 +17,8 @@ lookupInEnv (SymPath [] name) env =
case Map.lookup name (envBindings env) of
Just found -> Just (env, found)
Nothing -> case envParent env of
Just parent -> lookupInEnv (SymPath [] name) parent
Nothing -> Nothing
Just parent -> lookupInEnv (SymPath [] name) parent
Nothing -> Nothing
lookupInEnv path@(SymPath (p : ps) name) env =
case Map.lookup p (envBindings env) of
Just (Binder _ xobj) ->
@ -35,13 +34,14 @@ lookupInEnv path@(SymPath (p : ps) name) env =
findAllGlobalVariables :: Env -> [Binder]
findAllGlobalVariables env =
concatMap finder (envBindings env)
where finder :: Binder -> [Binder]
finder def@(Binder _ (XObj (Lst (XObj Def _ _ : _)) _ _)) =
[def]
finder (Binder _ (XObj (Mod innerEnv) _ _)) =
findAllGlobalVariables innerEnv
finder _ =
[]
where
finder :: Binder -> [Binder]
finder def@(Binder _ (XObj (Lst (XObj Def _ _ : _)) _ _)) =
[def]
finder (Binder _ (XObj (Mod innerEnv) _ _)) =
findAllGlobalVariables innerEnv
finder _ =
[]
-- | Find all the possible (imported) symbols that could be referred to
multiLookup :: String -> Env -> [(Env, Binder)]
@ -50,47 +50,42 @@ multiLookup = multiLookupInternal False
multiLookupALL :: String -> Env -> [(Env, Binder)]
multiLookupALL = multiLookupInternal True
-- TODO: Many of the local functions defined in the body of multiLookupInternal have been extracted.
-- Remove the duplication and define this in terms of the more generic/extracted functions.
{-# ANN multiLookupInternal "HLint: ignore Eta reduce" #-}
-- | The advanced version of multiLookup that allows for looking into modules that are NOT imported.
-- | Perhaps this function will become unnecessary when all functions can be found through Interfaces? (even 'delete', etc.)
multiLookupInternal :: Bool -> String -> Env -> [(Env, Binder)]
multiLookupInternal allowLookupInAllModules name rootEnv = recursiveLookup rootEnv
where lookupInLocalEnv :: String -> Env -> Maybe (Env, Binder)
lookupInLocalEnv n localEnv = case Map.lookup n (envBindings localEnv) of -- No recurse!
Just b -> Just (localEnv, b)
Nothing -> Nothing
importsAll :: Env -> [Env]
importsAll env =
let envs = mapMaybe (binderToEnv . snd) (Map.toList (envBindings env))
in envs ++ concatMap importsAll envs
-- Only lookup in imported modules (nonrecursively!)
importsNormal :: Env -> [Env]
importsNormal env =
mapMaybe (\path -> fmap getEnvFromBinder (lookupInEnv path env)) (envUseModules env)
importsLookup :: Env -> [(Env, Binder)]
importsLookup env =
let envs = (if allowLookupInAllModules then importsAll else importsNormal) env
in mapMaybe (lookupInLocalEnv name) envs
recursiveLookup :: Env -> [(Env, Binder)]
recursiveLookup env =
let spine = case Map.lookup name (envBindings env) of
Just found -> [(env, found)]
Nothing -> []
leaves = importsLookup env
above = case envParent env of
Just parent -> recursiveLookup parent
Nothing -> []
in --(trace $ "multiLookupInternal '" ++ name ++ "' " ++ show (envModuleName env) ++ ", spine: " ++ show (fmap snd spine) ++ ", leaves: " ++ show (fmap snd leaves) ++ ", above: " ++ show (fmap snd above))
spine ++ leaves ++ above
where
lookupInLocalEnv :: String -> Env -> Maybe (Env, Binder)
lookupInLocalEnv n localEnv = case Map.lookup n (envBindings localEnv) of -- No recurse!
Just b -> Just (localEnv, b)
Nothing -> Nothing
importsAll :: Env -> [Env]
importsAll env =
let envs = mapMaybe (binderToEnv . snd) (Map.toList (envBindings env))
in envs ++ concatMap importsAll envs
-- Only lookup in imported modules (nonrecursively!)
importsNormal :: Env -> [Env]
importsNormal env =
mapMaybe (\path -> fmap getEnvFromBinder (lookupInEnv path env)) (envUseModules env)
importsLookup :: Env -> [(Env, Binder)]
importsLookup env =
let envs = (if allowLookupInAllModules then importsAll else importsNormal) env
in mapMaybe (lookupInLocalEnv name) envs
recursiveLookup :: Env -> [(Env, Binder)]
recursiveLookup env =
let spine = case Map.lookup name (envBindings env) of
Just found -> [(env, found)]
Nothing -> []
leaves = importsLookup env
above = case envParent env of
Just parent -> recursiveLookup parent
Nothing -> []
in --(trace $ "multiLookupInternal '" ++ name ++ "' " ++ show (envModuleName env) ++ ", spine: " ++ show (fmap snd spine) ++ ", leaves: " ++ show (fmap snd leaves) ++ ", above: " ++ show (fmap snd above))
spine ++ leaves ++ above
binderToEnv :: Binder -> Maybe Env
binderToEnv (Binder _ (XObj (Mod e) _ _)) = Just e
@ -101,7 +96,7 @@ binderToEnv _ = Nothing
importedEnvs :: Env -> [Env]
importedEnvs env =
let envs = mapMaybe (binderToEnv . snd) (Map.toList (envBindings env))
in envs ++ concatMap importedEnvs envs
in envs ++ concatMap importedEnvs envs
-- | Given an environment, use a lookup function to recursively find all binders
-- in the environment that satisfy the lookup.
@ -110,32 +105,34 @@ recursiveLookupAll input lookf env =
let spine = lookf input env
leaves = concatMap (lookf input) (importedEnvs env)
above = case envParent env of
Just parent -> recursiveLookupAll input lookf parent
Nothing -> []
in spine ++ leaves ++ above
Just parent -> recursiveLookupAll input lookf parent
Nothing -> []
in spine ++ leaves ++ above
-- | Lookup binders by name.
lookupByName :: String -> Env -> [Binder]
lookupByName name env =
let filtered = Map.filterWithKey (\k _ -> k == name) (envBindings env)
in map snd $ Map.toList filtered
in map snd $ Map.toList filtered
-- | Lookup binders that have specified metadata.
lookupByMeta :: String -> Env -> [Binder]
lookupByMeta key env =
let filtered = Map.filter hasMeta (envBindings env)
in map snd $ Map.toList filtered
where hasMeta b = Meta.binderMember key b
in map snd $ Map.toList filtered
where
hasMeta b = Meta.binderMember key b
-- | Given an interface, lookup all binders that implement the interface.
lookupImplementations :: SymPath -> Env -> [Binder]
lookupImplementations interface env =
let binders = lookupByMeta "implements" env
in filter isImpl binders
where isImpl (Binder meta _) =
case Meta.get "implements" meta of
Just (XObj (Lst interfaces) _ _) -> interface `elem` (map getPath interfaces)
_ -> False
in filter isImpl binders
where
isImpl (Binder meta _) =
case Meta.get "implements" meta of
Just (XObj (Lst interfaces) _ _) -> interface `elem` (map getPath interfaces)
_ -> False
getEnvFromBinder :: (a, Binder) -> Env
getEnvFromBinder (_, Binder _ (XObj (Mod foundEnv) _ _)) = foundEnv
@ -148,7 +145,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:_) _) 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:
@ -157,16 +154,17 @@ multiLookupQualified path@(SymPath (p:_) _) rootEnv =
Nothing -> []
Just _ -> inexactMatch
Nothing -> inexactMatch
where inexactMatch =
-- No exact match on the first qualifier, will look in various places for a match:
let fromParent = case envParent rootEnv of
Just parent -> multiLookupQualified path parent
Nothing -> []
fromUsedModules = let usedModules = envUseModules rootEnv
envs = mapMaybe (\path' -> fmap getEnvFromBinder (lookupInEnv path' rootEnv)) usedModules
in concatMap (multiLookupQualified path) envs
in fromParent ++ fromUsedModules
where
inexactMatch =
-- No exact match on the first qualifier, will look in various places for a match:
let fromParent = case envParent rootEnv of
Just parent -> multiLookupQualified path parent
Nothing -> []
fromUsedModules =
let usedModules = envUseModules rootEnv
envs = mapMaybe (\path' -> fmap getEnvFromBinder (lookupInEnv path' rootEnv)) usedModules
in concatMap (multiLookupQualified path) envs
in fromParent ++ fromUsedModules
-- | Add an XObj to a specific environment. TODO: rename to envInsert
extendEnv :: Env -> String -> XObj -> Env
@ -176,29 +174,30 @@ extendEnv env name xobj = envAddBinding env name (Binder emptyMeta xobj)
envInsertAt :: Env -> SymPath -> Binder -> Env
envInsertAt env (SymPath [] name) binder =
envAddBinding env name binder
envInsertAt env (SymPath (p:ps) name) xobj =
envInsertAt env (SymPath (p : ps) name) xobj =
case Map.lookup p (envBindings env) of
Just (Binder meta (XObj (Mod innerEnv) i t)) ->
let newInnerEnv = Binder meta (XObj (Mod (envInsertAt innerEnv (SymPath ps name) xobj)) i t)
in env { envBindings = Map.insert p newInnerEnv (envBindings env) }
in env {envBindings = Map.insert p newInnerEnv (envBindings env)}
Just _ -> error ("Can't insert into non-module: " ++ p)
Nothing -> error ("Can't insert into non-existing module: " ++ p)
envReplaceEnvAt :: Env -> [String] -> Env -> Env
envReplaceEnvAt _ [] replacement = replacement
envReplaceEnvAt env (p:ps) replacement =
envReplaceEnvAt env (p : ps) replacement =
case Map.lookup p (envBindings env) of
Just (Binder _ (XObj (Mod innerEnv) i t)) ->
let newInnerEnv = Binder emptyMeta (XObj (Mod (envReplaceEnvAt innerEnv ps replacement)) i t)
in env { envBindings = Map.insert p newInnerEnv (envBindings env) }
in env {envBindings = Map.insert p newInnerEnv (envBindings env)}
Just _ -> error ("Can't replace non-module: " ++ p)
Nothing -> error ("Can't replace non-existing module: " ++ p)
-- | Add a Binder to a specific environment.
envAddBinding :: Env -> String -> Binder -> Env
envAddBinding env name binder = env { envBindings = Map.insert name binder (envBindings env) }
envAddBinding env name binder = env {envBindings = Map.insert name binder (envBindings env)}
{-# ANN addListOfBindings "HLint: ignore Eta reduce" #-}
-- | Add a list of bindings to an environment
addListOfBindings :: Env -> [(String, Binder)] -> Env
addListOfBindings env bindingsToAdd = foldl' (\e (n, b) -> envAddBinding e n b) env bindingsToAdd
@ -206,14 +205,14 @@ addListOfBindings env bindingsToAdd = foldl' (\e (n, b) -> envAddBinding e n b)
-- | Get an inner environment.
getEnv :: Env -> [String] -> Env
getEnv env [] = env
getEnv env (p:ps) = case Map.lookup p (envBindings env) of
Just (Binder _ (XObj (Mod innerEnv) _ _)) -> getEnv innerEnv ps
Just _ -> error "Can't get non-env."
Nothing -> error "Can't get env."
getEnv env (p : ps) = case Map.lookup p (envBindings env) of
Just (Binder _ (XObj (Mod innerEnv) _ _)) -> getEnv innerEnv ps
Just _ -> error "Can't get non-env."
Nothing -> error "Can't get env."
contextEnv :: Context -> Env
contextEnv Context{contextInternalEnv=Just e} = e
contextEnv Context{contextGlobalEnv=e, contextPath=p} = getEnv e p
contextEnv Context {contextInternalEnv = Just e} = e
contextEnv Context {contextGlobalEnv = e, contextPath = p} = getEnv e p
-- | Checks if an environment is "external", meaning it's either the global scope or a module scope.
envIsExternal :: Env -> Bool
@ -239,22 +238,22 @@ isExternalType _ _ =
-- | Is this type managed - does it need to be freed?
isManaged :: TypeEnv -> Ty -> Bool
isManaged typeEnv (StructTy (ConcreteNameTy name) _) =
(name == "Array") || (name == "StaticArray") || (name == "Dictionary") || (
case lookupInEnv (SymPath [] name) (getTypeEnv typeEnv) of
Just (_, Binder _ (XObj (Lst (XObj (ExternalType _) _ _ : _)) _ _)) -> False
Just (_, Binder _ (XObj (Lst (XObj (Deftype _) _ _ : _)) _ _)) -> True
Just (_, Binder _ (XObj (Lst (XObj (DefSumtype _) _ _ : _)) _ _)) -> True
Just (_, Binder _ (XObj wrong _ _)) -> error ("Invalid XObj in type env: " ++ show wrong)
Nothing -> error ("Can't find " ++ name ++ " in type env.") -- TODO: Please don't crash here!
)
isManaged _ StringTy = True
(name == "Array") || (name == "StaticArray") || (name == "Dictionary")
|| ( case lookupInEnv (SymPath [] name) (getTypeEnv typeEnv) of
Just (_, Binder _ (XObj (Lst (XObj (ExternalType _) _ _ : _)) _ _)) -> False
Just (_, Binder _ (XObj (Lst (XObj (Deftype _) _ _ : _)) _ _)) -> True
Just (_, Binder _ (XObj (Lst (XObj (DefSumtype _) _ _ : _)) _ _)) -> True
Just (_, Binder _ (XObj wrong _ _)) -> error ("Invalid XObj in type env: " ++ show wrong)
Nothing -> error ("Can't find " ++ name ++ " in type env.") -- TODO: Please don't crash here!
)
isManaged _ StringTy = True
isManaged _ PatternTy = True
isManaged _ FuncTy{} = True
isManaged _ FuncTy {} = True
isManaged _ _ = False
-- | Is this type a function type?
isFunctionType :: Ty -> Bool
isFunctionType FuncTy{} = True
isFunctionType FuncTy {} = True
isFunctionType _ = False
-- | Is this type a struct type?
@ -265,7 +264,7 @@ isStructType _ = False
keysInEnvEditDistance :: SymPath -> Env -> Int -> [String]
keysInEnvEditDistance (SymPath [] name) env distance =
let candidates = Map.filterWithKey (\k _ -> levenshteinDistance defaultEditCosts k name < distance) (envBindings env)
in Map.keys candidates
in Map.keys candidates
keysInEnvEditDistance path@(SymPath (p : ps) name) env distance =
case Map.lookup p (envBindings env) of
Just (Binder _ xobj) ->
@ -288,12 +287,12 @@ envReplaceBinding s@(SymPath [] name) binder env =
Nothing -> env
envReplaceBinding (SymPath _ _) _ _ = error "TODO: cannot replace qualified bindings"
bindingNames :: Env -> [String]
bindingNames = concatMap select . envBindings
where select :: Binder -> [String]
select (Binder _ (XObj (Mod i) _ _)) = bindingNames i
select (Binder _ obj) = [getName obj]
where
select :: Binder -> [String]
select (Binder _ (XObj (Mod i) _ _)) = bindingNames i
select (Binder _ obj) = [getName obj]
existingMeta :: Env -> XObj -> MetaData
existingMeta globalEnv xobj =

40
src/Meta.hs
View File

@ -1,12 +1,14 @@
module Meta (stub,
get,
set,
fromBinder,
getBinderMetaValue,
updateBinderMeta,
Meta.member,
binderMember
) where
module Meta
( stub,
get,
set,
fromBinder,
getBinderMetaValue,
updateBinderMeta,
Meta.member,
binderMember,
)
where
import Data.Map as Map
import Info
@ -19,11 +21,19 @@ import Types
-- (doc foo "A foo.") <- foo hasn't been declared yet.
-- (def foo 0)
stub :: SymPath -> Binder
stub path = (Binder emptyMeta
(XObj (Lst [XObj MetaStub Nothing Nothing
, XObj (Sym path Symbol) Nothing Nothing])
(Just dummyInfo)
(Just (VarTy "a"))))
stub path =
( Binder
emptyMeta
( XObj
( Lst
[ XObj MetaStub Nothing Nothing,
XObj (Sym path Symbol) Nothing Nothing
]
)
(Just dummyInfo)
(Just (VarTy "a"))
)
)
get :: String -> MetaData -> Maybe XObj
get key meta = Map.lookup key $ getMeta meta
@ -40,7 +50,7 @@ getBinderMetaValue key binder =
updateBinderMeta :: Binder -> String -> XObj -> Binder
updateBinderMeta binder key value =
binder { binderMeta = set key value $ fromBinder binder }
binder {binderMeta = set key value $ fromBinder binder}
member :: String -> MetaData -> Bool
member key meta = Map.member key $ getMeta meta

861
src/Obj.hs
View File

File diff suppressed because it is too large Load Diff

874
src/Parsing.hs
View File

File diff suppressed because it is too large Load Diff

5
src/Path.hs
View File

@ -1,4 +1,5 @@
module Path where
import qualified System.Directory as D
import qualified System.FilePath.Posix as FP
import qualified System.FilePath.Windows as FPW
@ -7,8 +8,8 @@ import Util
(</>) :: FilePath -> FilePath -> FilePath
(</>) = case platform of
Windows -> (FPW.</>)
_ -> (FP.</>)
Windows -> (FPW.</>)
_ -> (FP.</>)
cachePath :: FilePath -> IO FilePath
cachePath = xdgPath D.XdgCache

25
src/Polymorphism.hs
View File

@ -1,8 +1,8 @@
module Polymorphism where
import Lookup
import Obj
import Types
import Lookup
-- | Calculate the full, mangled name of a concretized polymorphic function.
-- | For example, The 'id' in "(id 3)" will become 'id__int'.
@ -11,18 +11,17 @@ import Lookup
-- | and similar for internal use.
-- | TODO: Environments are passed in different order here!!!
nameOfPolymorphicFunction :: TypeEnv -> Env -> Ty -> String -> Maybe SymPath
nameOfPolymorphicFunction _ env functionType functionName =
let foundBinders = multiLookupALL functionName env
in case filter ((\(Just t') -> areUnifiable functionType t') . xobjTy . binderXObj . snd) foundBinders of
[] -> Nothing
[(_, Binder _ (XObj (Lst (XObj (External (Just name)) _ _ : _)) _ _))] ->
Just (SymPath [] name)
[(_, Binder _ single)] ->
let Just t' = xobjTy single
(SymPath pathStrings name) = getPath single
suffix = polymorphicSuffix t' functionType
concretizedPath = SymPath pathStrings (name ++ suffix)
in Just concretizedPath
_ -> Nothing
in case filter ((\(Just t') -> areUnifiable functionType t') . xobjTy . binderXObj . snd) foundBinders of
[] -> Nothing
[(_, Binder _ (XObj (Lst (XObj (External (Just name)) _ _ : _)) _ _))] ->
Just (SymPath [] name)
[(_, Binder _ single)] ->
let Just t' = xobjTy single
(SymPath pathStrings name) = getPath single
suffix = polymorphicSuffix t' functionType
concretizedPath = SymPath pathStrings (name ++ suffix)
in Just concretizedPath
_ -> Nothing

1199
src/Primitives.hs
View File

File diff suppressed because it is too large Load Diff

148
src/Project.hs
View File

@ -1,100 +1,106 @@
{-# LANGUAGE RecordWildCards #-}
module Project where
import Info
import Util
data Target = Native | Target String
instance Show Target where
show Native = "native"
show (Target x) = x
-- | Project (represents a lot of useful information for working at the REPL and building executables)
data Project = Project { projectTitle :: String
, projectIncludes :: [Includer]
, projectCFlags :: [String]
, projectLibFlags :: [String]
, projectPkgConfigFlags :: [String]
, projectFiles :: [(FilePath, ReloadMode)]
, projectAlreadyLoaded :: [FilePath]
, projectEchoC :: Bool
, projectLibDir :: FilePath
, projectCarpDir :: FilePath
, projectOutDir :: FilePath
, projectDocsDir :: FilePath
, projectDocsLogo :: FilePath
, projectDocsPrelude :: String
, projectDocsURL :: String
, projectDocsGenerateIndex :: Bool
, projectDocsStyling :: String
, projectPrompt :: String
, projectCarpSearchPaths :: [FilePath]
, projectPrintTypedAST :: Bool
, projectCompiler :: String
, projectTarget :: Target
, projectCore :: Bool
, projectEchoCompilationCommand :: Bool
, projectCanExecute :: Bool
, projectFilePathPrintLength :: FilePathPrintLength
, projectGenerateOnly :: Bool
, projectBalanceHints :: Bool
, projectForceReload :: Bool -- Setting this to true will make the `load-once` command work just like `load`.
, projectCModules :: [FilePath]
, projectLoadStack :: [FilePath]
}
data Project
= Project
{ projectTitle :: String,
projectIncludes :: [Includer],
projectCFlags :: [String],
projectLibFlags :: [String],
projectPkgConfigFlags :: [String],
projectFiles :: [(FilePath, ReloadMode)],
projectAlreadyLoaded :: [FilePath],
projectEchoC :: Bool,
projectLibDir :: FilePath,
projectCarpDir :: FilePath,
projectOutDir :: FilePath,
projectDocsDir :: FilePath,
projectDocsLogo :: FilePath,
projectDocsPrelude :: String,
projectDocsURL :: String,
projectDocsGenerateIndex :: Bool,
projectDocsStyling :: String,
projectPrompt :: String,
projectCarpSearchPaths :: [FilePath],
projectPrintTypedAST :: Bool,
projectCompiler :: String,
projectTarget :: Target,
projectCore :: Bool,
projectEchoCompilationCommand :: Bool,
projectCanExecute :: Bool,
projectFilePathPrintLength :: FilePathPrintLength,
projectGenerateOnly :: Bool,
projectBalanceHints :: Bool,
projectForceReload :: Bool, -- Setting this to true will make the `load-once` command work just like `load`.
projectCModules :: [FilePath],
projectLoadStack :: [FilePath]
}
projectFlags :: Project -> String
projectFlags proj = joinWithSpace (projectCFlags proj ++ projectLibFlags proj)
instance Show Project where
show (Project {..}) =
unlines [ "Title: " ++ projectTitle
, "Compiler: " ++ projectCompiler
, "Target: " ++ show projectTarget
, "Includes:\n " ++ joinIndented (map show projectIncludes)
, "Cflags:\n " ++ joinIndented projectCFlags
, "Library flags:\n " ++ joinIndented projectLibFlags
, "Flags for pkg-config:\n "++ joinIndented projectPkgConfigFlags
, "Carp source files:\n " ++ joinIndented (map showLoader projectFiles)
, "Already loaded:\n " ++ joinIndented projectAlreadyLoaded
, "Echo C: " ++ showB projectEchoC
, "Echo compilation command: " ++ showB projectEchoCompilationCommand
, "Can execute: " ++ showB projectCanExecute
, "Output directory: " ++ projectOutDir
, "Docs directory: " ++ projectDocsDir
, "Docs logo: " ++ projectDocsLogo
, "Docs prelude: " ++ projectDocsPrelude
, "Docs Project URL: " ++ projectDocsURL
, "Docs generate index: " ++ showB projectDocsGenerateIndex
, "Docs CSS URL: " ++ projectDocsStyling
, "Library directory: " ++ projectLibDir
, "CARP_DIR: " ++ projectCarpDir
, "Prompt: " ++ projectPrompt
, "Using Core: " ++ showB projectCore
, "Search paths for 'load' command:\n " ++ joinIndented projectCarpSearchPaths
, "Print AST (with 'info' command): " ++ showB projectPrintTypedAST
, "File path print length (when using --check): " ++ show projectFilePathPrintLength
, "Generate Only: " ++ showB projectGenerateOnly
, "Balance Hints: " ++ showB projectBalanceHints
, "Force Reload: " ++ showB projectForceReload
, "C modules:\n " ++ joinIndented projectCModules
, "Load stack:\n "++ joinIndented projectLoadStack
]
where showB b = if b then "true" else "false"
joinIndented = joinWith "\n "
unlines
[ "Title: " ++ projectTitle,
"Compiler: " ++ projectCompiler,
"Target: " ++ show projectTarget,
"Includes:\n " ++ joinIndented (map show projectIncludes),
"Cflags:\n " ++ joinIndented projectCFlags,
"Library flags:\n " ++ joinIndented projectLibFlags,
"Flags for pkg-config:\n " ++ joinIndented projectPkgConfigFlags,
"Carp source files:\n " ++ joinIndented (map showLoader projectFiles),
"Already loaded:\n " ++ joinIndented projectAlreadyLoaded,
"Echo C: " ++ showB projectEchoC,
"Echo compilation command: " ++ showB projectEchoCompilationCommand,
"Can execute: " ++ showB projectCanExecute,
"Output directory: " ++ projectOutDir,
"Docs directory: " ++ projectDocsDir,
"Docs logo: " ++ projectDocsLogo,
"Docs prelude: " ++ projectDocsPrelude,
"Docs Project URL: " ++ projectDocsURL,
"Docs generate index: " ++ showB projectDocsGenerateIndex,
"Docs CSS URL: " ++ projectDocsStyling,
"Library directory: " ++ projectLibDir,
"CARP_DIR: " ++ projectCarpDir,
"Prompt: " ++ projectPrompt,
"Using Core: " ++ showB projectCore,
"Search paths for 'load' command:\n " ++ joinIndented projectCarpSearchPaths,
"Print AST (with 'info' command): " ++ showB projectPrintTypedAST,
"File path print length (when using --check): " ++ show projectFilePathPrintLength,
"Generate Only: " ++ showB projectGenerateOnly,
"Balance Hints: " ++ showB projectBalanceHints,
"Force Reload: " ++ showB projectForceReload,
"C modules:\n " ++ joinIndented projectCModules,
"Load stack:\n " ++ joinIndented projectLoadStack
]
where
showB b = if b then "true" else "false"
joinIndented = joinWith "\n "
-- | Represent the inclusion of a C header file, either like <string.h> or "string.h"
data Includer = SystemInclude String
| RelativeInclude String
deriving Eq
data Includer
= SystemInclude String
| RelativeInclude String
deriving (Eq)
instance Show Includer where
show (SystemInclude file) = "<" ++ file ++ ">"
show (RelativeInclude file) = "\"" ++ file ++ "\""
-- | This flag is used on Carp source files to decide wether to reload them or not when calling `(reload)` / `:r`
data ReloadMode = DoesReload | Frozen deriving Show
data ReloadMode = DoesReload | Frozen deriving (Show)
showLoader :: (FilePath, ReloadMode) -> String
showLoader (fp, DoesReload) = fp

303
src/Qualify.hs
View File

@ -1,14 +1,13 @@
module Qualify where
import qualified Data.Map as Map
import Data.List (foldl')
import qualified Data.Map as Map
import Debug.Trace
import Types
import Obj
import Lookup
import Util
import Info
import Lookup
import Obj
import Types
import Util
-- | Changes the symbol part of a defn (the name) to a new symbol path
-- | Example: (defn foo () 123) => (defn GreatModule.foo () 123)
@ -23,87 +22,113 @@ setFullyQualifiedDefn xobj _ = error ("Can't set new path on " ++ show xobj)
-- | This must run after the 'setFullyQualifiedDefn' function has fixed the paths of all bindings in the environment.
-- | This function does NOT go into function-body scope environments and the like.
setFullyQualifiedSymbols :: TypeEnv -> Env -> Env -> XObj -> XObj
setFullyQualifiedSymbols typeEnv globalEnv env (XObj (Lst [defn@(XObj (Defn _) _ _),
sym@(XObj (Sym (SymPath _ functionName) _) _ _),
args@(XObj (Arr argsArr) _ _),
body])
i t) =
-- For self-recursion, there must be a binding to the function in the inner env.
-- It is marked as RecursionEnv basically is the same thing as external to not mess up lookup.
-- Inside the recursion env is the function env that contains bindings for the arguments of the function.
-- Note: These inner envs is ephemeral since they are not stored in a module or global scope.
let recursionEnv = Env Map.empty (Just env) (Just (functionName ++ "-recurse-env")) [] RecursionEnv 0
envWithSelf = extendEnv recursionEnv functionName sym
functionEnv = Env Map.empty (Just envWithSelf) Nothing [] InternalEnv 0
envWithArgs = foldl' (\e arg@(XObj (Sym (SymPath _ argSymName) _) _ _) -> extendEnv e argSymName arg) functionEnv argsArr
in XObj (Lst [defn, sym, args, setFullyQualifiedSymbols typeEnv globalEnv envWithArgs body]) i t
setFullyQualifiedSymbols typeEnv globalEnv env (XObj (Lst [fn@(XObj (Fn _ _) _ _),
args@(XObj (Arr argsArr) _ _),
body])
i t) =
let lvl = envFunctionNestingLevel env
functionEnv = Env Map.empty (Just env) Nothing [] InternalEnv (lvl + 1)
envWithArgs = foldl' (\e arg@(XObj (Sym (SymPath _ argSymName) _) _ _) -> extendEnv e argSymName arg) functionEnv argsArr
in XObj (Lst [fn, args, setFullyQualifiedSymbols typeEnv globalEnv envWithArgs body]) i t
setFullyQualifiedSymbols
typeEnv
globalEnv
env
( XObj
( Lst
[ defn@(XObj (Defn _) _ _),
sym@(XObj (Sym (SymPath _ functionName) _) _ _),
args@(XObj (Arr argsArr) _ _),
body
]
)
i
t
) =
-- For self-recursion, there must be a binding to the function in the inner env.
-- It is marked as RecursionEnv basically is the same thing as external to not mess up lookup.
-- Inside the recursion env is the function env that contains bindings for the arguments of the function.
-- Note: These inner envs is ephemeral since they are not stored in a module or global scope.
let recursionEnv = Env Map.empty (Just env) (Just (functionName ++ "-recurse-env")) [] RecursionEnv 0
envWithSelf = extendEnv recursionEnv functionName sym
functionEnv = Env Map.empty (Just envWithSelf) Nothing [] InternalEnv 0
envWithArgs = foldl' (\e arg@(XObj (Sym (SymPath _ argSymName) _) _ _) -> extendEnv e argSymName arg) functionEnv argsArr
in XObj (Lst [defn, sym, args, setFullyQualifiedSymbols typeEnv globalEnv envWithArgs body]) i t
setFullyQualifiedSymbols
typeEnv
globalEnv
env
( XObj
( Lst
[ fn@(XObj (Fn _ _) _ _),
args@(XObj (Arr argsArr) _ _),
body
]
)
i
t
) =
let lvl = envFunctionNestingLevel env
functionEnv = Env Map.empty (Just env) Nothing [] InternalEnv (lvl + 1)
envWithArgs = foldl' (\e arg@(XObj (Sym (SymPath _ argSymName) _) _ _) -> extendEnv e argSymName arg) functionEnv argsArr
in XObj (Lst [fn, args, setFullyQualifiedSymbols typeEnv globalEnv envWithArgs body]) i t
setFullyQualifiedSymbols typeEnv globalEnv env (XObj (Lst [the@(XObj The _ _), typeXObj, value]) i t) =
let value' = setFullyQualifiedSymbols typeEnv globalEnv env value
in XObj (Lst [the, typeXObj, value']) i t
in XObj (Lst [the, typeXObj, value']) i t
setFullyQualifiedSymbols typeEnv globalEnv env (XObj (Lst [def@(XObj Def _ _), sym, expr]) i t) =
let expr' = setFullyQualifiedSymbols typeEnv globalEnv env expr
in XObj (Lst [def, sym, expr']) i t
in XObj (Lst [def, sym, expr']) i t
setFullyQualifiedSymbols typeEnv globalEnv env (XObj (Lst [letExpr@(XObj Let _ _), bind@(XObj (Arr bindings) bindi bindt), body]) i t)
| odd (length bindings) = XObj (Lst [letExpr, bind, body]) i t -- Leave it untouched for the compiler to find the error.
| not (all isSym (evenIndices bindings)) = XObj (Lst [letExpr, bind, body]) i t -- Leave it untouched for the compiler to find the error.
| otherwise = let Just ii = i
lvl = envFunctionNestingLevel env
innerEnv = Env Map.empty (Just env) (Just ("let-env-" ++ show (infoIdentifier ii))) [] InternalEnv lvl
(innerEnv', bindings') =
foldl' (\(e, bs) (s@(XObj (Sym (SymPath _ binderName) _) _ _), o) ->
let qualified = setFullyQualifiedSymbols typeEnv globalEnv e o
in (extendEnv e binderName s, bs ++ [s, qualified]))
(innerEnv, []) (pairwise bindings)
newBody = setFullyQualifiedSymbols typeEnv globalEnv innerEnv' body
in XObj (Lst [letExpr, XObj (Arr bindings') bindi bindt, newBody]) i t
| otherwise =
let Just ii = i
lvl = envFunctionNestingLevel env
innerEnv = Env Map.empty (Just env) (Just ("let-env-" ++ show (infoIdentifier ii))) [] InternalEnv lvl
(innerEnv', bindings') =
foldl'
( \(e, bs) (s@(XObj (Sym (SymPath _ binderName) _) _ _), o) ->
let qualified = setFullyQualifiedSymbols typeEnv globalEnv e o
in (extendEnv e binderName s, bs ++ [s, qualified])
)
(innerEnv, [])
(pairwise bindings)
newBody = setFullyQualifiedSymbols typeEnv globalEnv innerEnv' body
in XObj (Lst [letExpr, XObj (Arr bindings') bindi bindt, newBody]) i t
setFullyQualifiedSymbols typeEnv globalEnv env (XObj (Lst (matchExpr@(XObj (Match _) _ _) : expr : casesXObjs)) i t) =
if even (length casesXObjs)
then let newExpr = setFullyQualifiedSymbols typeEnv globalEnv env expr
Just ii = i
lvl = envFunctionNestingLevel env
innerEnv = Env Map.empty (Just env) (Just ("case-env-" ++ show (infoIdentifier ii))) [] InternalEnv lvl
newCasesXObjs =
map (\(l, r) ->
case l of
XObj (Lst (_:xs)) _ _ ->
let l' = setFullyQualifiedSymbols typeEnv globalEnv env l
innerEnv' = foldl' folder innerEnv xs
where folder e v = case v of
XObj (Sym (SymPath _ binderName) _) _ _ ->
extendEnv e binderName v
-- Nested sumtypes
-- fold recursively -- is there a more efficient way?
XObj (Lst(_:ys)) _ _ ->
foldl' folder innerEnv ys
x ->
error ("Can't match variable with " ++ show x)
r' = setFullyQualifiedSymbols typeEnv globalEnv innerEnv' r
in [l', r']
XObj{} ->
let l' = setFullyQualifiedSymbols typeEnv globalEnv env l
r' = setFullyQualifiedSymbols typeEnv globalEnv env r
in [l', r']
) (pairwise casesXObjs)
in XObj (Lst (matchExpr : newExpr : concat newCasesXObjs)) i t
else XObj (Lst (matchExpr : expr : casesXObjs)) i t -- Leave it untouched for the compiler to find the error.
then
let newExpr = setFullyQualifiedSymbols typeEnv globalEnv env expr
Just ii = i
lvl = envFunctionNestingLevel env
innerEnv = Env Map.empty (Just env) (Just ("case-env-" ++ show (infoIdentifier ii))) [] InternalEnv lvl
newCasesXObjs =
map
( \(l, r) ->
case l of
XObj (Lst (_ : xs)) _ _ ->
let l' = setFullyQualifiedSymbols typeEnv globalEnv env l
innerEnv' = foldl' folder innerEnv xs
where
folder e v = case v of
XObj (Sym (SymPath _ binderName) _) _ _ ->
extendEnv e binderName v
-- Nested sumtypes
-- fold recursively -- is there a more efficient way?
XObj (Lst (_ : ys)) _ _ ->
foldl' folder innerEnv ys
x ->
error ("Can't match variable with " ++ show x)
r' = setFullyQualifiedSymbols typeEnv globalEnv innerEnv' r
in [l', r']
XObj {} ->
let l' = setFullyQualifiedSymbols typeEnv globalEnv env l
r' = setFullyQualifiedSymbols typeEnv globalEnv env r
in [l', r']
)
(pairwise casesXObjs)
in XObj (Lst (matchExpr : newExpr : concat newCasesXObjs)) i t
else XObj (Lst (matchExpr : expr : casesXObjs)) i t -- Leave it untouched for the compiler to find the error.
setFullyQualifiedSymbols typeEnv globalEnv env (XObj (Lst [XObj With _ _, XObj (Sym path _) _ _, expression]) _ _) =
let useThese = envUseModules env
env' = if path `elem` useThese then env else env { envUseModules = path : useThese }
in setFullyQualifiedSymbols typeEnv globalEnv env' expression
env' = if path `elem` useThese then env else env {envUseModules = path : useThese}
in setFullyQualifiedSymbols typeEnv globalEnv env' expression
setFullyQualifiedSymbols typeEnv globalEnv env (XObj (Lst xobjs) i t) =
-- TODO: Perhaps this general case can be sufficient? No need with all the cases above..?
let xobjs' = map (setFullyQualifiedSymbols typeEnv globalEnv env) xobjs
in XObj (Lst xobjs') i t
in XObj (Lst xobjs') i t
setFullyQualifiedSymbols typeEnv globalEnv localEnv xobj@(XObj (Sym path _) i t) =
case path of
-- Unqualified:
@ -115,11 +140,11 @@ setFullyQualifiedSymbols typeEnv globalEnv localEnv xobj@(XObj (Sym path _) i t)
case lookupInEnv path localEnv of
Just (foundEnv, _) ->
if envIsExternal foundEnv
then createInterfaceSym name
else doesNotBelongToAnInterface False localEnv
then createInterfaceSym name
else doesNotBelongToAnInterface False localEnv
Nothing ->
--trace ("Will turn '" ++ show path ++ "' " ++ prettyInfoFromXObj xobj ++ " into an interface symbol.")
createInterfaceSym name
createInterfaceSym name
_ ->
doesNotBelongToAnInterface False localEnv
-- Qualified:
@ -128,76 +153,78 @@ setFullyQualifiedSymbols typeEnv globalEnv localEnv xobj@(XObj (Sym path _) i t)
where
createInterfaceSym name =
XObj (InterfaceSym name) i t
captureOrNot foundEnv = if envFunctionNestingLevel foundEnv < envFunctionNestingLevel localEnv
then Capture (envFunctionNestingLevel localEnv - envFunctionNestingLevel foundEnv)
else NoCapture
captureOrNot foundEnv =
if envFunctionNestingLevel foundEnv < envFunctionNestingLevel localEnv
then Capture (envFunctionNestingLevel localEnv - envFunctionNestingLevel foundEnv)
else NoCapture
doesNotBelongToAnInterface :: Bool -> Env -> XObj
doesNotBelongToAnInterface finalRecurse theEnv =
let results = multiLookupQualified path theEnv
results' = removeThoseShadowedByRecursiveSymbol results
in
case results' of
[] -> case envParent theEnv of
Just p ->
doesNotBelongToAnInterface False p
Nothing ->
-- | OBS! The environment with no parent is the global env but it's an old one without the latest bindings!
if finalRecurse
then xobj -- This was the TRUE global env, stop here and leave 'xobj' as is.
else doesNotBelongToAnInterface True globalEnv
[(_, Binder _ foundOne@(XObj (Lst (XObj (External (Just overrideWithName)) _ _ : _)) _ _))] ->
XObj (Sym (getPath foundOne) (LookupGlobalOverride overrideWithName)) i t
[(e, Binder _ (XObj (Mod modEnv) _ _))] ->
-- Lookup of a "naked" module name means that the Carp code is trying to
-- instantiate a (nested) module with an implicit .init, e.g. (Pair 1 2)
case envModuleName modEnv of
Nothing -> error ("Can't get name from unqualified module path: " ++ show path)
Just name ->
let pathHere = pathToEnv e
in XObj (Sym (SymPath (pathHere ++ [name]) "init") (LookupGlobal CarpLand AFunction)) i t
[(e, Binder _ foundOne)] ->
case envMode e of
ExternalEnv -> XObj (Sym (getPath foundOne)
(LookupGlobal (if isExternalFunction foundOne then ExternalCode else CarpLand) (definitionMode foundOne))) i t
RecursionEnv -> XObj (Sym (getPath foundOne) LookupRecursive) i t
_ -> --trace ("\nLOCAL variable " ++ show (getPath foundOne) ++ ":\n" ++ prettyEnvironmentChain e) $
XObj (Sym (getPath foundOne) (LookupLocal (captureOrNot e))) i t
multiple ->
case filter (not . envIsExternal . fst) multiple of
-- There is at least one local binding, use the path of that one:
(e, Binder _ local) : _ -> XObj (Sym (getPath local) (LookupLocal (captureOrNot e))) i t
-- There are no local bindings, this is allowed to become a multi lookup symbol:
[] ->
-- (trace $ "Turned " ++ show path ++ " into multisym: " ++ joinWithComma (map (show . (\(e, b) -> (getPath (binderXObj b), safeEnvModuleName e, envMode e))) multiple)) $
case path of
(SymPath [] name) ->
-- Create a MultiSym!
XObj (MultiSym name (map (getPath . binderXObj . snd) multiple)) i t
pathWithQualifiers ->
-- The symbol IS qualified but can't be found, should produce an error later during compilation.
trace ("PROBLEMATIC: " ++ show path) (XObj (Sym pathWithQualifiers (LookupGlobal CarpLand AFunction)) i t)
in case results' of
[] -> case envParent theEnv of
Just p ->
doesNotBelongToAnInterface False p
Nothing ->
-- OBS! The environment with no parent is the global env but it's an old one without the latest bindings!
if finalRecurse
then xobj -- This was the TRUE global env, stop here and leave 'xobj' as is.
else doesNotBelongToAnInterface True globalEnv
[(_, Binder _ foundOne@(XObj (Lst (XObj (External (Just overrideWithName)) _ _ : _)) _ _))] ->
XObj (Sym (getPath foundOne) (LookupGlobalOverride overrideWithName)) i t
[(e, Binder _ (XObj (Mod modEnv) _ _))] ->
-- Lookup of a "naked" module name means that the Carp code is trying to
-- instantiate a (nested) module with an implicit .init, e.g. (Pair 1 2)
case envModuleName modEnv of
Nothing -> error ("Can't get name from unqualified module path: " ++ show path)
Just name ->
let pathHere = pathToEnv e
in XObj (Sym (SymPath (pathHere ++ [name]) "init") (LookupGlobal CarpLand AFunction)) i t
[(e, Binder _ foundOne)] ->
case envMode e of
ExternalEnv ->
XObj
( Sym
(getPath foundOne)
(LookupGlobal (if isExternalFunction foundOne then ExternalCode else CarpLand) (definitionMode foundOne))
)
i
t
RecursionEnv -> XObj (Sym (getPath foundOne) LookupRecursive) i t
_ ->
--trace ("\nLOCAL variable " ++ show (getPath foundOne) ++ ":\n" ++ prettyEnvironmentChain e) $
XObj (Sym (getPath foundOne) (LookupLocal (captureOrNot e))) i t
multiple ->
case filter (not . envIsExternal . fst) multiple of
-- There is at least one local binding, use the path of that one:
(e, Binder _ local) : _ -> XObj (Sym (getPath local) (LookupLocal (captureOrNot e))) i t
-- There are no local bindings, this is allowed to become a multi lookup symbol:
[] ->
-- (trace $ "Turned " ++ show path ++ " into multisym: " ++ joinWithComma (map (show . (\(e, b) -> (getPath (binderXObj b), safeEnvModuleName e, envMode e))) multiple)) $
case path of
(SymPath [] name) ->
-- Create a MultiSym!
XObj (MultiSym name (map (getPath . binderXObj . snd) multiple)) i t
pathWithQualifiers ->
-- The symbol IS qualified but can't be found, should produce an error later during compilation.
trace ("PROBLEMATIC: " ++ show path) (XObj (Sym pathWithQualifiers (LookupGlobal CarpLand AFunction)) i t)
removeThoseShadowedByRecursiveSymbol :: [(Env, Binder)] -> [(Env, Binder)]
removeThoseShadowedByRecursiveSymbol allBinders = visit allBinders allBinders
where visit bs res =
foldl
(\result b ->
case b of
(Env { envMode = RecursionEnv }, Binder _ xobj') ->
remove (\(_, Binder _ x) -> xobj' /= x && getName xobj' == getName x) result
_ -> result)
res
bs
where
visit bs res =
foldl
( \result b ->
case b of
(Env {envMode = RecursionEnv}, Binder _ xobj') ->
remove (\(_, Binder _ x) -> xobj' /= x && getName xobj' == getName x) result
_ -> result
)
res
bs
setFullyQualifiedSymbols typeEnv globalEnv env (XObj (Arr array) i t) =
let array' = map (setFullyQualifiedSymbols typeEnv globalEnv env) array
in XObj (Arr array') i t
in XObj (Arr 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
in XObj (StaticArr array') i t
setFullyQualifiedSymbols _ _ _ xobj = xobj

6
src/Reify.hs
View File

@ -2,10 +2,10 @@
-- corresponding representations in the Carp language.
module Reify where
import Types
import Obj
import Types
-- | The Reifiable class ranges over internal Carp compiler types that
-- | The Reifiable class ranges over internal Carp compiler types that
-- may have corresponding representations in Carp itself.
class Reifiable a where
reify :: a -> XObj
@ -15,7 +15,7 @@ symbol x = XObj (Sym (SymPath [] (show x)) Symbol) Nothing Nothing
-- Show on strings results in a symbol that includes quotes ""
-- This function is the same as symbol, for string literals.
literal :: String -> XObj
literal :: String -> XObj
literal x = XObj (Sym (SymPath [] x) Symbol) Nothing Nothing
array :: (Reifiable a) => [a] -> XObj

161
src/RenderDocs.hs
View File

@ -2,32 +2,35 @@
module RenderDocs where
import AssignTypes (typeVariablesInOrderOfAppearance)
import CMark
import Control.Monad (when)
import qualified Data.List as List
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
import Data.Text as Text
import qualified Meta
import Obj
import Path
import Project
import Text.Blaze.Html.Renderer.Pretty (renderHtml)
import qualified Text.Blaze.Html5 as H
import Text.Blaze.Html5 ((!))
import qualified Text.Blaze.Html5.Attributes as A
import Text.Blaze.Html.Renderer.Pretty (renderHtml)
import Data.Maybe (fromMaybe)
import Data.Text as Text
import qualified Data.Map as Map
import qualified Data.List as List
import Obj
import Project
import Types
import Path
import AssignTypes (typeVariablesInOrderOfAppearance)
import qualified Meta
-- TODO: Move the beautification to a much earlier place, preferably when the function is defined/concretized-
-- This might be a duplicate with the work in a PR by @jacereda
beautifyType :: Ty -> Ty
beautifyType t =
let tys = List.nub (typeVariablesInOrderOfAppearance t)
mappings = Map.fromList (List.zip (List.map (\(VarTy name) -> name) tys)
(List.map (VarTy . (:[])) ['a'..]))
in replaceTyVars mappings t
mappings =
Map.fromList
( List.zip
(List.map (\(VarTy name) -> name) tys)
(List.map (VarTy . (: [])) ['a' ..])
)
in replaceTyVars mappings t
saveDocsForEnvs :: Project -> [(SymPath, Binder)] -> IO ()
saveDocsForEnvs ctx pathsAndEnvBinders =
@ -35,10 +38,15 @@ saveDocsForEnvs ctx pathsAndEnvBinders =
title = projectTitle ctx
generateIndex = projectDocsGenerateIndex ctx
allEnvNames = fmap (getModuleName . fst . getEnvAndMetaFromBinder . snd) pathsAndEnvBinders
in do mapM_ (saveDocsForEnvBinder ctx allEnvNames) pathsAndEnvBinders
when generateIndex (writeFile (dir </> title ++ "_index.html")
(projectIndexPage ctx allEnvNames))
putStrLn ("Generated docs to '" ++ dir ++ "'")
in do
mapM_ (saveDocsForEnvBinder ctx allEnvNames) pathsAndEnvBinders
when
generateIndex
( writeFile
(dir </> title ++ "_index.html")
(projectIndexPage ctx allEnvNames)
)
putStrLn ("Generated docs to '" ++ dir ++ "'")
-- | This function expects a binder that contains an environment, anything else is a runtime error.
getEnvAndMetaFromBinder :: Binder -> (Env, MetaData)
@ -55,36 +63,42 @@ projectIndexPage ctx moduleNames =
htmlHeader = H.toHtml $ projectTitle ctx
htmlDoc = commonmarkToHtml [optSafe] $ Text.pack $ projectDocsPrelude ctx
html = renderHtml $ H.docTypeHtml $
do headOfPage css
H.body $
H.div ! A.class_ "content" $
H.a ! A.href (H.stringValue url) $
do H.div ! A.class_ "logo" $
do H.img ! A.src (H.stringValue logo) ! A.alt "Logo"
moduleIndex moduleNames
H.div $
do H.h1 htmlHeader
H.preEscapedToHtml htmlDoc
in html
do
headOfPage css
H.body
$ H.div ! A.class_ "content"
$ H.a ! A.href (H.stringValue url)
$ do
H.div ! A.class_ "logo" $
do
H.img ! A.src (H.stringValue logo) ! A.alt "Logo"
moduleIndex moduleNames
H.div $
do
H.h1 htmlHeader
H.preEscapedToHtml htmlDoc
in html
headOfPage :: String -> H.Html
headOfPage css =
H.head $
do H.meta ! A.charset "UTF-8"
H.meta ! A.name "viewport" ! A.content "width=device-width, initial-scale=1.0, maximum-scale=1.0, user-scalable=0"
H.link ! A.rel "stylesheet" ! A.href (H.stringValue css)
do
H.meta ! A.charset "UTF-8"
H.meta ! A.name "viewport" ! A.content "width=device-width, initial-scale=1.0, maximum-scale=1.0, user-scalable=0"
H.link ! A.rel "stylesheet" ! A.href (H.stringValue css)
getModuleName :: Env -> String
getModuleName env = fromMaybe "Global" (envModuleName env)
saveDocsForEnvBinder :: Project -> [String] -> (SymPath, Binder) -> IO ()
saveDocsForEnvBinder ctx moduleNames (envPath, envBinder) =
do let SymPath _ moduleName = envPath
dir = projectDocsDir ctx
fullPath = dir </> moduleName ++ ".html"
string = renderHtml (envBinderToHtml envBinder ctx (show envPath) moduleNames)
createDirectoryIfMissing False dir
writeFile fullPath string
do
let SymPath _ moduleName = envPath
dir = projectDocsDir ctx
fullPath = dir </> moduleName ++ ".html"
string = renderHtml (envBinderToHtml envBinder ctx (show envPath) moduleNames)
createDirectoryIfMissing False dir
writeFile fullPath string
envBinderToHtml :: Binder -> Project -> String -> [String] -> H.Html
envBinderToHtml envBinder ctx moduleName moduleNames =
@ -94,22 +108,25 @@ envBinderToHtml envBinder ctx moduleName moduleNames =
url = projectDocsURL ctx
logo = projectDocsLogo ctx
moduleDescription = case Meta.get "doc" meta of
Just (XObj (Str s) _ _) -> s
Nothing -> ""
Just (XObj (Str s) _ _) -> s
Nothing -> ""
moduleDescriptionHtml = commonmarkToHtml [optSafe] $ Text.pack moduleDescription
in H.docTypeHtml $
do headOfPage css
H.body $
H.div ! A.class_ "content" $
do H.div ! A.class_ "logo" $
do H.a ! A.href (H.stringValue url) $
H.img ! A.src (H.stringValue logo)
--span_ "CARP DOCS FOR"
H.div ! A.class_ "title" $ H.toHtml title
moduleIndex moduleNames
H.h1 (H.toHtml moduleName)
H.div ! A.class_ "module-description" $ H.preEscapedToHtml moduleDescriptionHtml
mapM_ (binderToHtml . snd) (Prelude.filter shouldEmitDocsForBinder (Map.toList (envBindings env)))
in H.docTypeHtml $
do
headOfPage css
H.body
$ H.div ! A.class_ "content"
$ do
H.div ! A.class_ "logo" $
do
H.a ! A.href (H.stringValue url) $
H.img ! A.src (H.stringValue logo)
--span_ "CARP DOCS FOR"
H.div ! A.class_ "title" $ H.toHtml title
moduleIndex moduleNames
H.h1 (H.toHtml moduleName)
H.div ! A.class_ "module-description" $ H.preEscapedToHtml moduleDescriptionHtml
mapM_ (binderToHtml . snd) (Prelude.filter shouldEmitDocsForBinder (Map.toList (envBindings env)))
shouldEmitDocsForBinder :: (String, Binder) -> Bool
shouldEmitDocsForBinder (_, Binder meta _) =
@ -117,34 +134,36 @@ shouldEmitDocsForBinder (_, Binder meta _) =
moduleIndex :: [String] -> H.Html
moduleIndex moduleNames =
H.div ! A.class_ "index" $
H.ul $ mapM_ moduleLink moduleNames
H.div ! A.class_ "index"
$ H.ul
$ mapM_ moduleLink moduleNames
moduleLink :: String -> H.Html
moduleLink name =
H.li $ H.a ! A.href (H.stringValue (name ++ ".html")) $ H.toHtml name
binderToHtml :: Binder -> H.Html
binderToHtml (Binder meta xobj) =
let name = getSimpleName xobj
maybeNameAndArgs = getSimpleNameWithArgs xobj
description = getBinderDescription xobj
typeSignature = case xobjTy xobj of
Just t -> show (beautifyType t) -- NOTE: This destroys user-defined names of type variables!
Nothing -> ""
Just t -> show (beautifyType t) -- NOTE: This destroys user-defined names of type variables!
Nothing -> ""
docString = case Meta.get "doc" meta of
Just (XObj (Str s) _ _) -> s
Just found -> pretty found
Nothing -> ""
Just (XObj (Str s) _ _) -> s
Just found -> pretty found
Nothing -> ""
htmlDoc = commonmarkToHtml [optSafe] $ Text.pack docString
in H.div ! A.class_ "binder" $
do H.a ! A.class_ "anchor" ! A.href (H.stringValue ("#" ++ name)) $
H.h3 ! A.id (H.stringValue name) $ H.toHtml name
H.div ! A.class_ "description" $ H.toHtml description
H.p ! A.class_ "sig" $ H.toHtml typeSignature
case maybeNameAndArgs of
Just nameAndArgs -> H.pre ! A.class_ "args" $ H.toHtml nameAndArgs
Nothing -> H.span $ H.toHtml (""::String)
H.p ! A.class_ "doc" $ H.preEscapedToHtml htmlDoc
--p_ (toHtml (description))
in H.div ! A.class_ "binder" $
do
H.a ! A.class_ "anchor" ! A.href (H.stringValue ("#" ++ name))
$ H.h3 ! A.id (H.stringValue name)
$ H.toHtml name
H.div ! A.class_ "description" $ H.toHtml description
H.p ! A.class_ "sig" $ H.toHtml typeSignature
case maybeNameAndArgs of
Just nameAndArgs -> H.pre ! A.class_ "args" $ H.toHtml nameAndArgs
Nothing -> H.span $ H.toHtml ("" :: String)
H.p ! A.class_ "doc" $ H.preEscapedToHtml htmlDoc
--p_ (toHtml (description))

228
src/Repl.hs
View File

@ -1,148 +1,152 @@
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
module Repl where
import System.Console.Haskeline ( getInputLine
, InputT
, runInputT
, Settings(..)
, Completion
, simpleCompletion
, completeWordWithPrev
)
import Data.List (isPrefixOf)
import Control.Monad.State.Strict
import System.Exit (exitSuccess)
import qualified Data.Map as Map
import Obj
import Project
import ColorText
import Control.Monad.State.Strict
import Data.List (isPrefixOf)
import qualified Data.Map as Map
import Eval
import Path
import Lookup
import Obj
import Parsing (balance)
import Path
import Project
import System.Console.Haskeline
( Completion,
InputT,
Settings (..),
completeWordWithPrev,
getInputLine,
runInputT,
simpleCompletion,
)
import System.Exit (exitSuccess)
completeKeywordsAnd :: Context -> String -> [Completion]
completeKeywordsAnd context word =
findKeywords word (bindingNames (contextGlobalEnv context) ++ keywords) []
where
findKeywords _ [] res = res
findKeywords match (x : xs) res =
if match `isPrefixOf` x
then findKeywords match xs (res ++ [simpleCompletion x])
else findKeywords match xs res
keywords = [ "Int" -- we should probably have a list of those somewhere
, "Float"
, "Double"
, "Bool"
, "String"
, "Char"
, "Array"
, "Fn"
, "def"
, "defn"
, "let"
, "do"
, "if"
, "while"
, "ref"
, "address"
, "set!"
, "the"
, "defmacro"
, "dynamic"
, "quote"
, "car"
, "cdr"
, "cons"
, "list"
, "array"
, "expand"
, "deftype"
, "register"
, "true"
, "false"
]
findKeywords _ [] res = res
findKeywords match (x : xs) res =
if match `isPrefixOf` x
then findKeywords match xs (res ++ [simpleCompletion x])
else findKeywords match xs res
keywords =
[ "Int", -- we should probably have a list of those somewhere
"Float",
"Double",
"Bool",
"String",
"Char",
"Array",
"Fn",
"def",
"defn",
"let",
"do",
"if",
"while",
"ref",
"address",
"set!",
"the",
"defmacro",
"dynamic",
"quote",
"car",
"cdr",
"cons",
"list",
"array",
"expand",
"deftype",
"register",
"true",
"false"
]
readlineSettings :: String -> Settings (StateT Context IO)
readlineSettings historyPath =
Settings {
complete = completeWordWithPrev Nothing ['(', ')', '[', ']', ' ', '\t', '\n']
(\_ w -> do
ctx <- get
pure (completeKeywordsAnd ctx w)),
historyFile = Just historyPath,
autoAddHistory = True
}
Settings
{ complete =
completeWordWithPrev
Nothing
['(', ')', '[', ']', ' ', '\t', '\n']
( \_ w -> do
ctx <- get
pure (completeKeywordsAnd ctx w)
),
historyFile = Just historyPath,
autoAddHistory = True
}
specialCommands :: Map.Map Char String
specialCommands = Map.fromList
[ ('x', "run")
, ('r', "reload")
, ('b', "build")
, ('c', "cat")
, ('e', "env")
, ('h', "help")
, ('p', "project")
, ('q', "quit")
, ('t', "type")
, ('m', "expand")
, ('i', "info")
]
specialCommands =
Map.fromList
[ ('x', "run"),
('r', "reload"),
('b', "build"),
('c', "cat"),
('e', "env"),
('h', "help"),
('p', "project"),
('q', "quit"),
('t', "type"),
('m', "expand"),
('i', "info")
]
rewriteError :: String -> String
rewriteError msg = "(macro-error \"" ++ msg ++ "\")"
treatSpecialInput :: String -> String
treatSpecialInput ":\n" = rewriteError "Unfinished special command"
treatSpecialInput (':':rest) =
treatSpecialInput (':' : rest) =
let cmdAndArgs = words rest
cmd = head cmdAndArgs
args = tail cmdAndArgs
in if length cmd == 1
then makeCommand args (head cmd)
else
if null args
then "(do " ++ unwords (map (makeCommand []) cmd) ++ ")"
else rewriteError "Can’t have grouped special command with arguments"
where makeCommand args cmd =
case Map.lookup cmd specialCommands of
Just command -> "(" ++ command ++ " " ++ unwords args ++ ")"
Nothing -> rewriteError ("Unknown special command: :" ++ [cmd])
in if length cmd == 1
then makeCommand args (head cmd)
else
if null args
then "(do " ++ unwords (map (makeCommand []) cmd) ++ ")"
else rewriteError "Can’t have grouped special command with arguments"
where
makeCommand args cmd =
case Map.lookup cmd specialCommands of
Just command -> "(" ++ command ++ " " ++ unwords args ++ ")"
Nothing -> rewriteError ("Unknown special command: :" ++ [cmd])
treatSpecialInput arg = arg
repl :: String -> String -> InputT (StateT Context IO) ()
repl readSoFar prompt =
do context <- lift $ get
input <- getInputLine (strWithColor Yellow prompt)
case input of
Nothing -> do
_ <- liftIO exitSuccess
pure ()
Just i -> do
let concatenated = readSoFar ++ i ++ "\n"
balanced = balance concatenated
proj = contextProj context
case balanced of
"" -> do
let input' = if concatenated == "\n" then contextLastInput context else concatenated -- Entering an empty string repeats last input
context' <- liftIO $ executeString True True (resetAlreadyLoadedFiles context) (treatSpecialInput input') "REPL"
lift $ put context'
repl "" (projectPrompt proj)
_ -> repl concatenated (if projectBalanceHints proj then balanced else "")
do
context <- lift $ get
input <- getInputLine (strWithColor Yellow prompt)
case input of
Nothing -> do
_ <- liftIO exitSuccess
pure ()
Just i -> do
let concatenated = readSoFar ++ i ++ "\n"
balanced = balance concatenated
proj = contextProj context
case balanced of
"" -> do
let input' = if concatenated == "\n" then contextLastInput context else concatenated -- Entering an empty string repeats last input
context' <- liftIO $ executeString True True (resetAlreadyLoadedFiles context) (treatSpecialInput input') "REPL"
lift $ put context'
repl "" (projectPrompt proj)
_ -> repl concatenated (if projectBalanceHints proj then balanced else "")
resetAlreadyLoadedFiles :: Context -> Context
resetAlreadyLoadedFiles context =
let proj = contextProj context
proj' = proj { projectAlreadyLoaded = [] }
in context { contextProj = proj' }
proj' = proj {projectAlreadyLoaded = []}
in context {contextProj = proj'}
runRepl :: Context -> IO ((), Context)
runRepl context = do

76
src/Scoring.hs
View File

@ -1,12 +1,11 @@
module Scoring (scoreTypeBinder, scoreValueBinder) where
import qualified Data.Set as Set
import Data.Maybe (fromJust)
import qualified Data.Set as Set
import Lookup
import Obj
import Types
import TypesToC
import Obj
import Lookup
-- | Scoring of types.
-- | The score is used for sorting the bindings before emitting them.
@ -16,10 +15,10 @@ scoreTypeBinder typeEnv b@(Binder _ (XObj (Lst (XObj x _ _ : XObj (Sym _ _) _ _
case x of
Defalias aliasedType ->
let selfName = ""
-- we add 1 here because deftypes generate aliases that
-- will at least have the same score as the type, but
-- need to come after. the increment represents this dependency
in (depthOfType typeEnv Set.empty selfName aliasedType + 1, b)
in -- we add 1 here because deftypes generate aliases that
-- will at least have the same score as the type, but
-- need to come after. the increment represents this dependency
(depthOfType typeEnv Set.empty selfName aliasedType + 1, b)
Deftype s -> depthOfStruct s
DefSumtype s -> depthOfStruct s
ExternalType _ -> (0, b)
@ -29,8 +28,6 @@ scoreTypeBinder typeEnv b@(Binder _ (XObj (Lst (XObj x _ _ : XObj (Sym _ _) _ _
case lookupInEnv (SymPath [] structName) (getTypeEnv typeEnv) of
Just (_, Binder _ typedef) -> (depthOfDeftype typeEnv Set.empty typedef varTys + 1, b)
Nothing -> error ("Can't find user defined type '" ++ structName ++ "' in type env.")
scoreTypeBinder _ b@(Binder _ (XObj (Mod _) _ _)) =
(1000, b)
scoreTypeBinder _ x = error ("Can't score: " ++ show x)
@ -42,15 +39,14 @@ depthOfDeftype typeEnv visited (XObj (Lst (_ : XObj (Sym (SymPath _ selfName) _)
xs -> maximum xs
where
depthsFromVarTys = map (depthOfType typeEnv visited selfName) varTys
expandCase :: XObj -> [Int]
expandCase (XObj (Arr arr) _ _) =
let members = memberXObjsToPairs arr
depthsFromMembers = map (depthOfType typeEnv visited selfName . snd) members
in depthsFromMembers ++ depthsFromVarTys
expandCase (XObj (Lst [XObj{}, XObj (Arr sumtypeCaseTys) _ _]) _ _) =
in depthsFromMembers ++ depthsFromVarTys
expandCase (XObj (Lst [XObj {}, XObj (Arr sumtypeCaseTys) _ _]) _ _) =
let depthsFromCaseTys = map (depthOfType typeEnv visited selfName . fromJust . xobjToTy) sumtypeCaseTys
in depthsFromCaseTys ++ depthsFromVarTys
in depthsFromCaseTys ++ depthsFromVarTys
expandCase (XObj (Sym _ _) _ _) =
[]
expandCase _ = error "Malformed case in typedef."
@ -60,8 +56,8 @@ depthOfDeftype _ _ xobj _ =
depthOfType :: TypeEnv -> Set.Set Ty -> String -> Ty -> Int
depthOfType typeEnv visited selfName theType =
if theType `elem` visited
then 0
else visitType theType + 1
then 0
else visitType theType + 1
where
visitType :: Ty -> Int
visitType t@(StructTy _ varTys) = depthOfStructType (tyToC t) varTys
@ -71,25 +67,25 @@ depthOfType typeEnv visited selfName theType =
visitType (PointerTy p) = visitType p
visitType (RefTy r lt) = max (visitType r) (visitType lt)
visitType _ = 1
depthOfStructType :: String -> [Ty] -> Int
depthOfStructType name varTys = 1 +
case name of
depthOfStructType name varTys = 1
+ case name of
"Array" -> depthOfVarTys
_ | name == selfName -> 1
_
| name == selfName -> 1
| otherwise ->
case lookupInEnv (SymPath [] name) (getTypeEnv typeEnv) of
Just (_, Binder _ typedef) -> depthOfDeftype typeEnv (Set.insert theType visited) typedef varTys
Nothing -> --trace ("Unknown type: " ++ name) $
depthOfVarTys -- The problem here is that generic types don't generate
-- their definition in time so we get nothing for those.
-- Instead, let's try the type vars.
where depthOfVarTys =
case fmap (depthOfType typeEnv visited name) varTys of
[] -> 1
xs -> maximum xs + 1
case lookupInEnv (SymPath [] name) (getTypeEnv typeEnv) of
Just (_, Binder _ typedef) -> depthOfDeftype typeEnv (Set.insert theType visited) typedef varTys
Nothing ->
--trace ("Unknown type: " ++ name) $
depthOfVarTys -- The problem here is that generic types don't generate
-- their definition in time so we get nothing for those.
-- Instead, let's try the type vars.
where
depthOfVarTys =
case fmap (depthOfType typeEnv visited name) varTys of
[] -> 1
xs -> maximum xs + 1
-- | Scoring of value bindings ('def' and 'defn')
-- | The score is used for sorting the bindings before emitting them.
@ -97,7 +93,7 @@ depthOfType typeEnv visited selfName theType =
scoreValueBinder :: Env -> Set.Set SymPath -> Binder -> (Int, Binder)
scoreValueBinder _ _ binder@(Binder _ (XObj (Lst (XObj (External _) _ _ : _)) _ _)) =
(0, binder)
scoreValueBinder globalEnv visited binder@(Binder _ (XObj (Lst [XObj Def _ _, XObj (Sym _ 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 _ Symbol) _ _, _, body]) _ _)) =
(scoreBody globalEnv visited body, binder)
@ -115,13 +111,13 @@ scoreBody globalEnv visited root = visit root
visitArray xobj
(Sym path (LookupGlobal _ _)) ->
if Set.member path visited
then 0
else case lookupInEnv path globalEnv of
Just (_, foundBinder) ->
let (score, _) = scoreValueBinder globalEnv (Set.insert path visited) foundBinder
in score + 1
Nothing ->
error ("Failed to lookup '" ++ show path ++ "'.")
then 0
else case lookupInEnv path globalEnv of
Just (_, foundBinder) ->
let (score, _) = scoreValueBinder globalEnv (Set.insert path visited) foundBinder
in score + 1
Nothing ->
error ("Failed to lookup '" ++ show path ++ "'.")
_ -> 0
visitList (XObj (Lst []) _ _) =
0

655
src/StartingEnv.hs
View File

@ -1,18 +1,17 @@
module StartingEnv where
import qualified Data.Set as Set
import qualified ArrayTemplates
import Commands
import qualified Data.Map as Map
import qualified Data.Set as Set
import Eval
import Info
import Obj
import Types
import Primitives
import qualified StaticArrayTemplates
import Template
import ToTemplate
import qualified ArrayTemplates
import qualified StaticArrayTemplates
import Commands
import Eval
import Primitives
import Info
import Types
-- | These modules will be loaded in order before any other code is evaluated.
coreModules :: String -> [String]
@ -20,345 +19,429 @@ coreModules carpDir = [carpDir ++ "/core/Core.carp"]
-- | The array module contains functions for working with the Array type.
arrayModule :: Env
arrayModule = Env { envBindings = bindings
, envParent = Nothing
, envModuleName = Just "Array"
, envUseModules = []
, envMode = ExternalEnv
, envFunctionNestingLevel = 0 }
where bindings = Map.fromList [ ArrayTemplates.templateNth
, ArrayTemplates.templateAllocate
, ArrayTemplates.templateEMap
, ArrayTemplates.templateEFilter
, ArrayTemplates.templateRaw
, ArrayTemplates.templateUnsafeRaw
, ArrayTemplates.templateAset
, ArrayTemplates.templateAsetBang
, ArrayTemplates.templateAsetUninitializedBang
, ArrayTemplates.templateLength
, ArrayTemplates.templatePushBack
, ArrayTemplates.templatePushBackBang
, ArrayTemplates.templatePopBack
, ArrayTemplates.templatePopBackBang
, ArrayTemplates.templateDeleteArray
, ArrayTemplates.templateCopyArray
, ArrayTemplates.templateStrArray
]
arrayModule =
Env
{ envBindings = bindings,
envParent = Nothing,
envModuleName = Just "Array",
envUseModules = [],
envMode = ExternalEnv,
envFunctionNestingLevel = 0
}
where
bindings =
Map.fromList
[ ArrayTemplates.templateNth,
ArrayTemplates.templateAllocate,
ArrayTemplates.templateEMap,
ArrayTemplates.templateEFilter,
ArrayTemplates.templateRaw,
ArrayTemplates.templateUnsafeRaw,
ArrayTemplates.templateAset,
ArrayTemplates.templateAsetBang,
ArrayTemplates.templateAsetUninitializedBang,
ArrayTemplates.templateLength,
ArrayTemplates.templatePushBack,
ArrayTemplates.templatePushBackBang,
ArrayTemplates.templatePopBack,
ArrayTemplates.templatePopBackBang,
ArrayTemplates.templateDeleteArray,
ArrayTemplates.templateCopyArray,
ArrayTemplates.templateStrArray
]
-- | The static array module
staticArrayModule :: Env
staticArrayModule = Env { envBindings = bindings
, envParent = Nothing
, envModuleName = Just "StaticArray"
, envUseModules = []
, envMode = ExternalEnv
, envFunctionNestingLevel = 0 }
where bindings = Map.fromList [ StaticArrayTemplates.templateUnsafeNth
, StaticArrayTemplates.templateLength
, StaticArrayTemplates.templateDeleteArray
, StaticArrayTemplates.templateAsetBang
, StaticArrayTemplates.templateStrArray
]
staticArrayModule =
Env
{ envBindings = bindings,
envParent = Nothing,
envModuleName = Just "StaticArray",
envUseModules = [],
envMode = ExternalEnv,
envFunctionNestingLevel = 0
}
where
bindings =
Map.fromList
[ StaticArrayTemplates.templateUnsafeNth,
StaticArrayTemplates.templateLength,
StaticArrayTemplates.templateDeleteArray,
StaticArrayTemplates.templateAsetBang,
StaticArrayTemplates.templateStrArray
]
-- | The Pointer module contains functions for dealing with pointers.
pointerModule :: Env
pointerModule = Env { envBindings = bindings
, envParent = Nothing
, envModuleName = Just "Pointer"
, envUseModules = []
, envMode = ExternalEnv
, envFunctionNestingLevel = 0 }
where bindings = Map.fromList [ templatePointerCopy
]
pointerModule =
Env
{ envBindings = bindings,
envParent = Nothing,
envModuleName = Just "Pointer",
envUseModules = [],
envMode = ExternalEnv,
envFunctionNestingLevel = 0
}
where
bindings =
Map.fromList
[ templatePointerCopy
]
-- | A template function for copying (= deref:ing) any pointer.
templatePointerCopy :: (String, Binder)
templatePointerCopy = defineTemplate
(SymPath ["Pointer"] "copy")
(FuncTy [RefTy (PointerTy (VarTy "p")) (VarTy "q")] (PointerTy (VarTy "p")) StaticLifetimeTy)
"copies a pointer `p`."
(toTemplate "$p* $NAME ($p** ptrRef)")
(toTemplate $ unlines ["$DECL {"
," return *ptrRef;"
,"}"])
(const [])
templatePointerCopy =
defineTemplate
(SymPath ["Pointer"] "copy")
(FuncTy [RefTy (PointerTy (VarTy "p")) (VarTy "q")] (PointerTy (VarTy "p")) StaticLifetimeTy)
"copies a pointer `p`."
(toTemplate "$p* $NAME ($p** ptrRef)")
( toTemplate $
unlines
[ "$DECL {",
" return *ptrRef;",
"}"
]
)
(const [])
maxArity :: Int
maxArity = 9
-- | The Function module contains functions for dealing with functions.
functionModule :: Env
functionModule = Env { envBindings = bindings
, envParent = Nothing
, envModuleName = Just "Function"
, envUseModules = []
, envMode = ExternalEnv
, envFunctionNestingLevel = 0 }
functionModule =
Env
{ envBindings = bindings,
envParent = Nothing,
envModuleName = Just "Function",
envUseModules = [],
envMode = ExternalEnv,
envFunctionNestingLevel = 0
}
where
bindEnv env = let Just name = envModuleName env
in (name, Binder emptyMeta (XObj (Mod env) Nothing Nothing))
bindings = Map.fromList (map (bindEnv . generateInnerFunctionModule) [0..maxArity])
bindEnv env =
let Just name = envModuleName env
in (name, Binder emptyMeta (XObj (Mod env) Nothing Nothing))
bindings = Map.fromList (map (bindEnv . generateInnerFunctionModule) [0 .. maxArity])
-- | Each arity of functions need their own module to enable copying and string representation
generateInnerFunctionModule :: Int -> Env
generateInnerFunctionModule arity =
Env { envBindings = bindings
, envParent = Nothing
, envModuleName = Just ("Arity" ++ show arity)
, envUseModules = []
, envMode = ExternalEnv
, envFunctionNestingLevel = 0
}
Env
{ envBindings = bindings,
envParent = Nothing,
envModuleName = Just ("Arity" ++ show arity),
envUseModules = [],
envMode = ExternalEnv,
envFunctionNestingLevel = 0
}
where
alphabet = ['d'..'y']
alphabet = ['d' .. 'y']
charToTyName c = [c]
funcTy = FuncTy (take arity (map (VarTy . charToTyName) alphabet)) (VarTy "z") StaticLifetimeTy
bindings = Map.fromList [ generateTemplateFuncCopy funcTy
, generateTemplateFuncDelete funcTy
, generateTemplateFuncStrOrPrn "str" "converts a function to a string." funcTy
, generateTemplateFuncStrOrPrn "prn" "converts a function to a string (internal representation)." funcTy
]
bindings =
Map.fromList
[ generateTemplateFuncCopy funcTy,
generateTemplateFuncDelete funcTy,
generateTemplateFuncStrOrPrn "str" "converts a function to a string." funcTy,
generateTemplateFuncStrOrPrn "prn" "converts a function to a string (internal representation)." funcTy
]
-- | A template function for generating 'copy' functions for function pointers.
generateTemplateFuncCopy :: Ty -> (String, Binder)
generateTemplateFuncCopy funcTy = defineTemplate
(SymPath ["Function"] "copy")
(FuncTy [RefTy funcTy (VarTy "q")] (VarTy "a") StaticLifetimeTy)
"copies a function."
(toTemplate "$a $NAME ($a* ref)")
(toTemplate $ unlines ["$DECL {"
," if(ref->env) {"
," $a f_copy;"
," f_copy.callback = ref->callback;"
," f_copy.delete = ref->delete;"
," f_copy.copy = ref->copy;"
," f_copy.env = ((void*(*)(void*))ref->copy)(ref->env);"
," return f_copy;"
," } else {"
," return *ref;"
," }"
,"}"])
(const [])
generateTemplateFuncCopy funcTy =
defineTemplate
(SymPath ["Function"] "copy")
(FuncTy [RefTy funcTy (VarTy "q")] (VarTy "a") StaticLifetimeTy)
"copies a function."
(toTemplate "$a $NAME ($a* ref)")
( toTemplate $
unlines
[ "$DECL {",
" if(ref->env) {",
" $a f_copy;",
" f_copy.callback = ref->callback;",
" f_copy.delete = ref->delete;",
" f_copy.copy = ref->copy;",
" f_copy.env = ((void*(*)(void*))ref->copy)(ref->env);",
" return f_copy;",
" } else {",
" return *ref;",
" }",
"}"
]
)
(const [])
-- | A template function for generating 'deleter' functions for function pointers.
generateTemplateFuncDelete :: Ty -> (String, Binder)
generateTemplateFuncDelete funcTy = defineTemplate
(SymPath ["Function"] "delete")
(FuncTy [funcTy] UnitTy StaticLifetimeTy)
"deletes a function."
(toTemplate "void $NAME (Lambda f)")
(toTemplate $ unlines ["$DECL {"
," if(f.delete) {"
," ((void(*)(void*))f.delete)(f.env);"
," CARP_FREE(f.env);"
," }"
,"}"])
(const [])
generateTemplateFuncDelete funcTy =
defineTemplate
(SymPath ["Function"] "delete")
(FuncTy [funcTy] UnitTy StaticLifetimeTy)
"deletes a function."
(toTemplate "void $NAME (Lambda f)")
( toTemplate $
unlines
[ "$DECL {",
" if(f.delete) {",
" ((void(*)(void*))f.delete)(f.env);",
" CARP_FREE(f.env);",
" }",
"}"
]
)
(const [])
-- | A template function for generating 'str' or 'prn' functions for function pointers.
generateTemplateFuncStrOrPrn :: String -> String -> Ty -> (String, Binder)
generateTemplateFuncStrOrPrn name docs funcTy = defineTemplate
(SymPath ["Function"] name)
(FuncTy [RefTy funcTy (VarTy "q")] StringTy StaticLifetimeTy)
docs
(toTemplate "String $NAME (Lambda *f)")
(toTemplate $ unlines ["$DECL {"
," static String lambda = \"λ\";"
," return String_copy(&lambda);"
,"}"])
(const [])
generateTemplateFuncStrOrPrn name docs funcTy =
defineTemplate
(SymPath ["Function"] name)
(FuncTy [RefTy funcTy (VarTy "q")] StringTy StaticLifetimeTy)
docs
(toTemplate "String $NAME (Lambda *f)")
( toTemplate $
unlines
[ "$DECL {",
" static String lambda = \"λ\";",
" return String_copy(&lambda);",
"}"
]
)
(const [])
-- | The dynamic module contains dynamic functions only available in the repl and during compilation.
dynamicModule :: Env
dynamicModule = Env { envBindings = bindings
, envParent = Nothing
, envModuleName = Just "Dynamic"
, envUseModules = []
, envMode = ExternalEnv
, envFunctionNestingLevel = 0 }
where path = ["Dynamic"]
bindings = Map.fromList $
[ addCommand (SymPath path "list?") 1 commandIsList "checks whether the argument is a list." "(list? '()) ; => true"
, addCommand (SymPath path "array?") 1 commandIsArray "checks whether the arguments is an array." "(array? []) ; => true"
, addCommand (SymPath path "symbol?") 1 commandIsSymbol "checks whether the argument is a symbol." "(symbol? 'x) ; => true"
, addCommand (SymPath path "length") 1 commandLength "returns the length of the argument (must be an array, string or list)." "(length '(1 2 3)) ; => 3"
, addCommand (SymPath path "car") 1 commandCar "gets the head of a list or array." "(car '(1 2 3)) ; => 1"
, addCommand (SymPath path "cdr") 1 commandCdr "gets the tail of a list or array." "(cdr '(1 2 3)) ; => '(2 3)"
, addCommand (SymPath path "last") 1 commandLast "gets the last element of a list or array." "(last '(1 2 3)) ; => 3"
, addCommand (SymPath path "all-but-last") 1 commandAllButLast "gets all elements except for the last one of a list or array." "(all-but-last '(1 2 3)) ; => '(1 2)"
, addCommand (SymPath path "cons") 2 commandCons "adds an element to the front of an array or list" "(cons 1 '(2 3)) ; => '(1 2 3)"
, addCommand (SymPath path "cons-last") 2 commandConsLast "adds an element to the back of an array or list" "(cons-last 3 '(1 2)) ; => '(1 2 3)"
, addCommand (SymPath path "append") 2 commandAppend "appends two lists or arrays." "(append '(1 2) '(3 4)) ; => '(1 2 3 4)"
, addCommandConfigurable (SymPath path "array") Nothing commandArray "creates an array from a collection of elements." "(array 1 2 3) ; => [1 2 3]"
, addCommandConfigurable (SymPath path "list") Nothing commandList "creates an array from a collection of elements." "(list 1 2 3) ; => (1 2 3)"
, addCommand (SymPath path "macro-error") 1 commandMacroError "logs an error and errors out of a macro." "(macro-error \"this is wrong\")"
, addCommandConfigurable (SymPath path "macro-log") Nothing commandMacroLog "logs a message in a macro." "(macro-log \"this will be printed at compile time\")"
, addCommandConfigurable (SymPath path "str") Nothing commandStr "stringifies its arguments." "(str 1 \" \" 2 \" \" 3) ; => \"1 2 3\""
, addCommand (SymPath path "not") 1 commandNot "negates its boolean argument." "(not false) ; => true"
, addCommand (SymPath path "=") 2 commandEq "compares its arguments for equality." "(= 1 2) ; => false"
, addCommand (SymPath path "<") 2 commandLt "checks whether its first argument is less than its second." "(< 1 2) ; => true"
, addCommand (SymPath path ">") 2 commandGt "checks whether its first argument is greater than its second." "(> 1 2) ; => false"
, addCommand (SymPath path "+") 2 commandPlus "adds its two arguments." "(+ 1 2) ; => 3"
, addCommand (SymPath path "-") 2 commandMinus "subtracts its second argument from its first." "(- 1 2) ; => -1"
, addCommand (SymPath path "/") 2 commandDiv "divides its first argument by its second." "(/ 4 2) ; => 2"
, addCommand (SymPath path "*") 2 commandMul "multiplies its two arguments." "(* 2 3) ; => 6"
, addCommand (SymPath path "c") 1 commandC "prints the C code emitted for a binding." "(c '(+ 2 3)) ; => int _3 = Int__PLUS_(2, 3);"
, addCommand (SymPath path "quit") 0 commandQuit "quits the program." "(quit)"
, addCommand (SymPath path "cat") 0 commandCat "spits out the generated C code." "(cat)"
, addCommand (SymPath path "run") 0 commandRunExe "runs the built executable." "(run)"
, addCommand (SymPath path "build") 0 (commandBuild False) "builds the current code to an executable." "(build)"
, addCommand (SymPath path "reload") 0 commandReload "reloads all currently loaded files that weren’t marked as only loading once (see `load` and `load-once`)." "(reload)"
, addCommand (SymPath path "env") 0 commandListBindings "lists all current bindings." "(env)"
, addCommand (SymPath path "project") 0 commandProject "prints the current project state." "(project)"
, addCommand (SymPath path "load") 1 commandLoad "loads a file into the current environment." "(load \"myfile.carp\")"
, addCommand (SymPath path "load-once") 1 commandLoadOnce "loads a file and prevents it from being reloaded (see `reload`)." "(load-once \"myfile.carp\")"
, addCommand (SymPath path "expand") 1 commandExpand "expands a macro and prints the result." "(expand '(when true 1)) ; => (if true 1 ())"
, addCommand (SymPath path "host-arch") 0 commandHostArch "prints the host architecture (as returned by the Haskell function `System.Info.arch`)." "(host-arch)"
, addCommand (SymPath path "host-os") 0 commandHostOS "prints the host operating system (as returned by the Haskell function `System.Info.os`)." "(host-os)"
, addCommand (SymPath path "system-include") 1 commandAddSystemInclude "adds a system include, i.e. a C `#include` with angle brackets (`<>`)." "(system-include \"stdint.h\")"
, addCommand (SymPath path "relative-include") 1 commandAddRelativeInclude "adds a relative include, i.e. a C `include` with quotes. It also prepends the current directory." "(relative-include \"myheader.h\")"
, addCommand (SymPath path "save-docs-internal") 1 commandSaveDocsInternal "is the internal companion command to `save-docs`. `save-docs` should be called instead." "(save-docs-internal 'Module)"
, addCommand (SymPath path "read-file") 1 commandReadFile "reads a file into a string." "(read-file \"myfile.txt\")"
, addCommand (SymPath path "write-file") 2 commandWriteFile "writes a string to a file." "(write-file \"myfile\" \"hello there!\")"
, addCommand (SymPath path "host-bit-width") 0 commandHostBitWidth "gets the bit width of the host platform." "(host-bit-width) ; => your host machine’s bit width, e.g. 32 or 64"
, addCommandConfigurable (SymPath path "s-expr") Nothing commandSexpression "returns the s-expression associated with a binding. When the binding is a type, the deftype form is returned instead of the type's module by default. Pass an optional bool argument to explicitly request the module for a type instead of its definition form. If the bool is true, the module for the type will be returned. Returns an error when no definition is found for the binding." "(s-expr foo), (s-expr foo true)"
, makePrim "quote" 1 "quotes any value." "(quote x) ; where x is an actual symbol" (\_ ctx [x] -> pure (ctx, Right x))
, makeVarPrim "file" "returns the file a symbol was defined in." "(file mysymbol)" primitiveFile
, makeVarPrim "line" "returns the line a symbol was defined on." "(line mysymbol)" primitiveLine
, makeVarPrim "column" "returns the column a symbol was defined on." "(column mysymbol)" primitiveColumn
, makePrim "info" 1 "prints all information associated with a symbol." "(info mysymbol)" primitiveInfo
, makeVarPrim "register-type" "registers a new type from C." "(register-type Name <optional: c-name> <optional: members>)" primitiveRegisterType
, makePrim "defmacro" 3 "defines a new macro." "(defmacro name [args :rest restargs] body)" primitiveDefmacro
, makePrim "defndynamic" 3 "defines a new dynamic function, i.e. a function available at compile time." "(defndynamic name [args] body)" primitiveDefndynamic
, makePrim "defdynamic" 2 "defines a new dynamic value, i.e. a value available at compile time." "(defdynamic name value)" primitiveDefdynamic
, makePrim "members" 1 "returns the members of a type as an array." "(members MyType)" primitiveMembers
, makeVarPrim "defmodule" "defines a new module in which `expressions` are defined." "(defmodule MyModule <expressions>)" primitiveDefmodule
, makePrim "meta-set!" 3 "sets a new key and value pair on the meta map associated with a symbol." "(meta-set! mysymbol \"mykey\" \"myval\")" primitiveMetaSet
, makePrim "meta" 2 "gets the value under `\"mykey\"` in the meta map associated with a symbol. It returns `()` if the key isn’t found." "(meta mysymbol \"mykey\")" primitiveMeta
, makePrim "definterface" 2 "defines a new interface (which could be a function or symbol)." "(definterface mysymbol MyType)" primitiveDefinterface
, makeVarPrim "register" "registers a new function. This is used to define C functions and other symbols that will be available at link time." "(register name <signature> <optional: override>)" primitiveRegister
, makeVarPrim "deftype" "defines a new sumtype or struct." "(deftype Name <members>)" primitiveDeftype
, makePrim "use" 1 "uses a module, i.e. imports the symbols inside that module into the current module." "(use MyModule)" primitiveUse
, makePrim "eval" 1 "evaluates a list." "(eval mycode)" primitiveEval
, makePrim "defined?" 1 "checks whether a symbol is defined." "(defined? mysymbol)" primitiveDefined
, makePrim "deftemplate" 4 "defines a new C template." "(deftemplate symbol Type declString defString)" primitiveDeftemplate
, makePrim "implements" 2 "designates a function as an implementation of an interface." "(implements zero Maybe.zero)" primitiveImplements
, makePrim "type" 1 "prints the type of a symbol." "(type mysymbol)" primitiveType
, makePrim "kind" 1 "prints the kind of a symbol." "(kind mysymbol)" primitiveKind
, makeVarPrim "help" "prints help." "(help)" primitiveHelp
]
++ [("String", Binder emptyMeta (XObj (Mod dynamicStringModule) Nothing Nothing))
,("Symbol", Binder emptyMeta (XObj (Mod dynamicSymModule) Nothing Nothing))
,("Project", Binder emptyMeta (XObj (Mod dynamicProjectModule) Nothing Nothing))
,("Path", Binder emptyMeta (XObj (Mod dynamicPathModule) Nothing Nothing))
]
dynamicModule =
Env
{ envBindings = bindings,
envParent = Nothing,
envModuleName = Just "Dynamic",
envUseModules = [],
envMode = ExternalEnv,
envFunctionNestingLevel = 0
}
where
path = ["Dynamic"]
bindings =
Map.fromList $
[ addCommand (SymPath path "list?") 1 commandIsList "checks whether the argument is a list." "(list? '()) ; => true",
addCommand (SymPath path "array?") 1 commandIsArray "checks whether the arguments is an array." "(array? []) ; => true",
addCommand (SymPath path "symbol?") 1 commandIsSymbol "checks whether the argument is a symbol." "(symbol? 'x) ; => true",
addCommand (SymPath path "length") 1 commandLength "returns the length of the argument (must be an array, string or list)." "(length '(1 2 3)) ; => 3",
addCommand (SymPath path "car") 1 commandCar "gets the head of a list or array." "(car '(1 2 3)) ; => 1",
addCommand (SymPath path "cdr") 1 commandCdr "gets the tail of a list or array." "(cdr '(1 2 3)) ; => '(2 3)",
addCommand (SymPath path "last") 1 commandLast "gets the last element of a list or array." "(last '(1 2 3)) ; => 3",
addCommand (SymPath path "all-but-last") 1 commandAllButLast "gets all elements except for the last one of a list or array." "(all-but-last '(1 2 3)) ; => '(1 2)",
addCommand (SymPath path "cons") 2 commandCons "adds an element to the front of an array or list" "(cons 1 '(2 3)) ; => '(1 2 3)",
addCommand (SymPath path "cons-last") 2 commandConsLast "adds an element to the back of an array or list" "(cons-last 3 '(1 2)) ; => '(1 2 3)",
addCommand (SymPath path "append") 2 commandAppend "appends two lists or arrays." "(append '(1 2) '(3 4)) ; => '(1 2 3 4)",
addCommandConfigurable (SymPath path "array") Nothing commandArray "creates an array from a collection of elements." "(array 1 2 3) ; => [1 2 3]",
addCommandConfigurable (SymPath path "list") Nothing commandList "creates an array from a collection of elements." "(list 1 2 3) ; => (1 2 3)",
addCommand (SymPath path "macro-error") 1 commandMacroError "logs an error and errors out of a macro." "(macro-error \"this is wrong\")",
addCommandConfigurable (SymPath path "macro-log") Nothing commandMacroLog "logs a message in a macro." "(macro-log \"this will be printed at compile time\")",
addCommandConfigurable (SymPath path "str") Nothing commandStr "stringifies its arguments." "(str 1 \" \" 2 \" \" 3) ; => \"1 2 3\"",
addCommand (SymPath path "not") 1 commandNot "negates its boolean argument." "(not false) ; => true",
addCommand (SymPath path "=") 2 commandEq "compares its arguments for equality." "(= 1 2) ; => false",
addCommand (SymPath path "<") 2 commandLt "checks whether its first argument is less than its second." "(< 1 2) ; => true",
addCommand (SymPath path ">") 2 commandGt "checks whether its first argument is greater than its second." "(> 1 2) ; => false",
addCommand (SymPath path "+") 2 commandPlus "adds its two arguments." "(+ 1 2) ; => 3",
addCommand (SymPath path "-") 2 commandMinus "subtracts its second argument from its first." "(- 1 2) ; => -1",
addCommand (SymPath path "/") 2 commandDiv "divides its first argument by its second." "(/ 4 2) ; => 2",
addCommand (SymPath path "*") 2 commandMul "multiplies its two arguments." "(* 2 3) ; => 6",
addCommand (SymPath path "c") 1 commandC "prints the C code emitted for a binding." "(c '(+ 2 3)) ; => int _3 = Int__PLUS_(2, 3);",
addCommand (SymPath path "quit") 0 commandQuit "quits the program." "(quit)",
addCommand (SymPath path "cat") 0 commandCat "spits out the generated C code." "(cat)",
addCommand (SymPath path "run") 0 commandRunExe "runs the built executable." "(run)",
addCommand (SymPath path "build") 0 (commandBuild False) "builds the current code to an executable." "(build)",
addCommand (SymPath path "reload") 0 commandReload "reloads all currently loaded files that weren’t marked as only loading once (see `load` and `load-once`)." "(reload)",
addCommand (SymPath path "env") 0 commandListBindings "lists all current bindings." "(env)",
addCommand (SymPath path "project") 0 commandProject "prints the current project state." "(project)",
addCommand (SymPath path "load") 1 commandLoad "loads a file into the current environment." "(load \"myfile.carp\")",
addCommand (SymPath path "load-once") 1 commandLoadOnce "loads a file and prevents it from being reloaded (see `reload`)." "(load-once \"myfile.carp\")",
addCommand (SymPath path "expand") 1 commandExpand "expands a macro and prints the result." "(expand '(when true 1)) ; => (if true 1 ())",
addCommand (SymPath path "host-arch") 0 commandHostArch "prints the host architecture (as returned by the Haskell function `System.Info.arch`)." "(host-arch)",
addCommand (SymPath path "host-os") 0 commandHostOS "prints the host operating system (as returned by the Haskell function `System.Info.os`)." "(host-os)",
addCommand (SymPath path "system-include") 1 commandAddSystemInclude "adds a system include, i.e. a C `#include` with angle brackets (`<>`)." "(system-include \"stdint.h\")",
addCommand (SymPath path "relative-include") 1 commandAddRelativeInclude "adds a relative include, i.e. a C `include` with quotes. It also prepends the current directory." "(relative-include \"myheader.h\")",
addCommand (SymPath path "save-docs-internal") 1 commandSaveDocsInternal "is the internal companion command to `save-docs`. `save-docs` should be called instead." "(save-docs-internal 'Module)",
addCommand (SymPath path "read-file") 1 commandReadFile "reads a file into a string." "(read-file \"myfile.txt\")",
addCommand (SymPath path "write-file") 2 commandWriteFile "writes a string to a file." "(write-file \"myfile\" \"hello there!\")",
addCommand (SymPath path "host-bit-width") 0 commandHostBitWidth "gets the bit width of the host platform." "(host-bit-width) ; => your host machine’s bit width, e.g. 32 or 64",
addCommandConfigurable (SymPath path "s-expr") Nothing commandSexpression "returns the s-expression associated with a binding. When the binding is a type, the deftype form is returned instead of the type's module by default. Pass an optional bool argument to explicitly request the module for a type instead of its definition form. If the bool is true, the module for the type will be returned. Returns an error when no definition is found for the binding." "(s-expr foo), (s-expr foo true)",
makePrim "quote" 1 "quotes any value." "(quote x) ; where x is an actual symbol" (\_ ctx [x] -> pure (ctx, Right x)),
makeVarPrim "file" "returns the file a symbol was defined in." "(file mysymbol)" primitiveFile,
makeVarPrim "line" "returns the line a symbol was defined on." "(line mysymbol)" primitiveLine,
makeVarPrim "column" "returns the column a symbol was defined on." "(column mysymbol)" primitiveColumn,
makePrim "info" 1 "prints all information associated with a symbol." "(info mysymbol)" primitiveInfo,
makeVarPrim "register-type" "registers a new type from C." "(register-type Name <optional: c-name> <optional: members>)" primitiveRegisterType,
makePrim "defmacro" 3 "defines a new macro." "(defmacro name [args :rest restargs] body)" primitiveDefmacro,
makePrim "defndynamic" 3 "defines a new dynamic function, i.e. a function available at compile time." "(defndynamic name [args] body)" primitiveDefndynamic,
makePrim "defdynamic" 2 "defines a new dynamic value, i.e. a value available at compile time." "(defdynamic name value)" primitiveDefdynamic,
makePrim "members" 1 "returns the members of a type as an array." "(members MyType)" primitiveMembers,
makeVarPrim "defmodule" "defines a new module in which `expressions` are defined." "(defmodule MyModule <expressions>)" primitiveDefmodule,
makePrim "meta-set!" 3 "sets a new key and value pair on the meta map associated with a symbol." "(meta-set! mysymbol \"mykey\" \"myval\")" primitiveMetaSet,
makePrim "meta" 2 "gets the value under `\"mykey\"` in the meta map associated with a symbol. It returns `()` if the key isn’t found." "(meta mysymbol \"mykey\")" primitiveMeta,
makePrim "definterface" 2 "defines a new interface (which could be a function or symbol)." "(definterface mysymbol MyType)" primitiveDefinterface,
makeVarPrim "register" "registers a new function. This is used to define C functions and other symbols that will be available at link time." "(register name <signature> <optional: override>)" primitiveRegister,
makeVarPrim "deftype" "defines a new sumtype or struct." "(deftype Name <members>)" primitiveDeftype,
makePrim "use" 1 "uses a module, i.e. imports the symbols inside that module into the current module." "(use MyModule)" primitiveUse,
makePrim "eval" 1 "evaluates a list." "(eval mycode)" primitiveEval,
makePrim "defined?" 1 "checks whether a symbol is defined." "(defined? mysymbol)" primitiveDefined,
makePrim "deftemplate" 4 "defines a new C template." "(deftemplate symbol Type declString defString)" primitiveDeftemplate,
makePrim "implements" 2 "designates a function as an implementation of an interface." "(implements zero Maybe.zero)" primitiveImplements,
makePrim "type" 1 "prints the type of a symbol." "(type mysymbol)" primitiveType,
makePrim "kind" 1 "prints the kind of a symbol." "(kind mysymbol)" primitiveKind,
makeVarPrim "help" "prints help." "(help)" primitiveHelp
]
++ [ ("String", Binder emptyMeta (XObj (Mod dynamicStringModule) Nothing Nothing)),
("Symbol", Binder emptyMeta (XObj (Mod dynamicSymModule) Nothing Nothing)),
("Project", Binder emptyMeta (XObj (Mod dynamicProjectModule) Nothing Nothing)),
("Path", Binder emptyMeta (XObj (Mod dynamicPathModule) Nothing Nothing))
]
-- | A submodule of the Dynamic module. Contains functions for working with strings in the repl or during compilation.
dynamicStringModule :: Env
dynamicStringModule = Env { envBindings = bindings
, envParent = Nothing
, envModuleName = Just "String"
, envUseModules = []
, envMode = ExternalEnv
, envFunctionNestingLevel = 0 }
where path = ["Dynamic", "String"]
bindings = Map.fromList [ addCommand (SymPath path "char-at") 2 commandCharAt "gets the nth character of a string." "(String.char-at \"hi\" 1) ; => \\i"
, addCommand (SymPath path "index-of") 2 commandIndexOf "gets the index of a character in a string (or returns `-1` if the character is not found)." "(index-of \"hi\" \\i) ; => 1"
, addCommand (SymPath path "slice") 3 commandSubstring "creates a substring from a beginning index to an end index." "(String.slice \"hello\" 1 3) ; => \"ell\""
, addCommand (SymPath path "length") 1 commandStringLength "gets the length of a string." "(String.length \"hi\") ; => 2"
, addCommand (SymPath path "concat") 1 commandStringConcat "concatenates a list of strings together." "(String.concat [\"hi \" \"there\"]) ; => \"hi there\""
, addCommand (SymPath path "split-on") 2 commandStringSplitOn "split a string at separator." "(String.split-on \"-\" \"hi-there\") ; => [\"hi \" \"there\"]"
]
dynamicStringModule =
Env
{ envBindings = bindings,
envParent = Nothing,
envModuleName = Just "String",
envUseModules = [],
envMode = ExternalEnv,
envFunctionNestingLevel = 0
}
where
path = ["Dynamic", "String"]
bindings =
Map.fromList
[ addCommand (SymPath path "char-at") 2 commandCharAt "gets the nth character of a string." "(String.char-at \"hi\" 1) ; => \\i",
addCommand (SymPath path "index-of") 2 commandIndexOf "gets the index of a character in a string (or returns `-1` if the character is not found)." "(index-of \"hi\" \\i) ; => 1",
addCommand (SymPath path "slice") 3 commandSubstring "creates a substring from a beginning index to an end index." "(String.slice \"hello\" 1 3) ; => \"ell\"",
addCommand (SymPath path "length") 1 commandStringLength "gets the length of a string." "(String.length \"hi\") ; => 2",
addCommand (SymPath path "concat") 1 commandStringConcat "concatenates a list of strings together." "(String.concat [\"hi \" \"there\"]) ; => \"hi there\"",
addCommand (SymPath path "split-on") 2 commandStringSplitOn "split a string at separator." "(String.split-on \"-\" \"hi-there\") ; => [\"hi \" \"there\"]"
]
-- | A submodule of the Dynamic module. Contains functions for working with symbols in the repl or during compilation.
dynamicSymModule :: Env
dynamicSymModule = Env { envBindings = bindings
, envParent = Nothing
, envModuleName = Just "Symbol"
, envUseModules = []
, envMode = ExternalEnv
, envFunctionNestingLevel = 0 }
where path = ["Dynamic", "Symbol"]
bindings = Map.fromList [ addCommand (SymPath path "concat") 1 commandSymConcat "concatenates a list of symbols together." "(Symbol.concat ['x 'y 'z]) ; => 'xyz"
, addCommand (SymPath path "prefix") 2 commandSymPrefix "prefixes a symbol with a module." "(Symbol.prefix 'Module 'fun) ; => Module.fun"
, addCommand (SymPath path "from") 1 commandSymFrom "converts a variety of types to a symbol." "(Symbol.from true) ; => True"
, addCommand (SymPath path "str") 1 commandSymStr "converts a symbol to a string." "(Symbol.str 'x) ; => \"x\""
]
dynamicSymModule =
Env
{ envBindings = bindings,
envParent = Nothing,
envModuleName = Just "Symbol",
envUseModules = [],
envMode = ExternalEnv,
envFunctionNestingLevel = 0
}
where
path = ["Dynamic", "Symbol"]
bindings =
Map.fromList
[ addCommand (SymPath path "concat") 1 commandSymConcat "concatenates a list of symbols together." "(Symbol.concat ['x 'y 'z]) ; => 'xyz",
addCommand (SymPath path "prefix") 2 commandSymPrefix "prefixes a symbol with a module." "(Symbol.prefix 'Module 'fun) ; => Module.fun",
addCommand (SymPath path "from") 1 commandSymFrom "converts a variety of types to a symbol." "(Symbol.from true) ; => True",
addCommand (SymPath path "str") 1 commandSymStr "converts a symbol to a string." "(Symbol.str 'x) ; => \"x\""
]
-- | A submodule of the Dynamic module. Contains functions for working with the active Carp project.
dynamicProjectModule :: Env
dynamicProjectModule = Env { envBindings = bindings
, envParent = Nothing
, envModuleName = Just "Project"
, envUseModules = []
, envMode = ExternalEnv
, envFunctionNestingLevel = 0 }
where path = ["Dynamic", "Project"]
bindings = Map.fromList [ addCommand (SymPath path "config") 2 commandProjectConfig "sets a project config key." "(Project.config \"paren-balance-hints\" false)"
, addCommand (SymPath path "get-config") 1 commandProjectGetConfig "gets a project config value under a key." "(Project.get-config \"paren-balance-hints\")"
]
dynamicProjectModule =
Env
{ envBindings = bindings,
envParent = Nothing,
envModuleName = Just "Project",
envUseModules = [],
envMode = ExternalEnv,
envFunctionNestingLevel = 0
}
where
path = ["Dynamic", "Project"]
bindings =
Map.fromList
[ addCommand (SymPath path "config") 2 commandProjectConfig "sets a project config key." "(Project.config \"paren-balance-hints\" false)",
addCommand (SymPath path "get-config") 1 commandProjectGetConfig "gets a project config value under a key." "(Project.get-config \"paren-balance-hints\")"
]
-- | A submodule of the Dynamic module. Contains functions for working with paths.
dynamicPathModule :: Env
dynamicPathModule = Env { envBindings = bindings
, envParent = Nothing
, envModuleName = Just "Path"
, envUseModules = []
, envMode = ExternalEnv
, envFunctionNestingLevel = 0 }
where path = ["Dynamic", "Path"]
bindings = Map.fromList [ addCommand (SymPath path "directory") 1 commandPathDirectory "takes the basename of a string taken to be a filepath.\n\nHistorical note: this is a command because it used to power one of the `include` macros." "(Path.directory \"dir/file\") ; => \"dir\""
, addCommand (SymPath path "absolute") 1 commandPathAbsolute "converts a filepath to absolute." "(Path.absolute \"dir/file\") ; => \"/home/foo/dir/file\""
]
dynamicPathModule =
Env
{ envBindings = bindings,
envParent = Nothing,
envModuleName = Just "Path",
envUseModules = [],
envMode = ExternalEnv,
envFunctionNestingLevel = 0
}
where
path = ["Dynamic", "Path"]
bindings =
Map.fromList
[ addCommand (SymPath path "directory") 1 commandPathDirectory "takes the basename of a string taken to be a filepath.\n\nHistorical note: this is a command because it used to power one of the `include` macros." "(Path.directory \"dir/file\") ; => \"dir\"",
addCommand (SymPath path "absolute") 1 commandPathAbsolute "converts a filepath to absolute." "(Path.absolute \"dir/file\") ; => \"/home/foo/dir/file\""
]
-- | The global environment before any code is run.
startingGlobalEnv :: Bool -> Env
startingGlobalEnv noArray =
Env { envBindings = bindings
, envParent = Nothing
, envModuleName = Nothing
, envUseModules = [SymPath [] "String"]
, envMode = ExternalEnv
, envFunctionNestingLevel = 0
}
where bindings = Map.fromList $ [ register "NULL" (PointerTy (VarTy "a"))
]
++ (if noArray then [] else [("Array", Binder emptyMeta (XObj (Mod arrayModule) Nothing Nothing))])
++ [("StaticArray", Binder emptyMeta (XObj (Mod staticArrayModule) Nothing Nothing))]
++ [("Pointer", Binder emptyMeta (XObj (Mod pointerModule) Nothing Nothing))]
++ [("Dynamic", Binder emptyMeta (XObj (Mod dynamicModule) Nothing Nothing))]
++ [("Function", Binder emptyMeta (XObj (Mod functionModule) Nothing Nothing))]
Env
{ envBindings = bindings,
envParent = Nothing,
envModuleName = Nothing,
envUseModules = [SymPath [] "String"],
envMode = ExternalEnv,
envFunctionNestingLevel = 0
}
where
bindings =
Map.fromList $
[ register "NULL" (PointerTy (VarTy "a"))
]
++ (if noArray then [] else [("Array", Binder emptyMeta (XObj (Mod arrayModule) Nothing Nothing))])
++ [("StaticArray", Binder emptyMeta (XObj (Mod staticArrayModule) Nothing Nothing))]
++ [("Pointer", Binder emptyMeta (XObj (Mod pointerModule) Nothing Nothing))]
++ [("Dynamic", Binder emptyMeta (XObj (Mod dynamicModule) Nothing Nothing))]
++ [("Function", Binder emptyMeta (XObj (Mod functionModule) Nothing Nothing))]
-- | The type environment (containing deftypes and interfaces) before any code is run.
startingTypeEnv :: Env
startingTypeEnv = Env { envBindings = bindings
, envParent = Nothing
, envModuleName = Nothing
, envUseModules = []
, envMode = ExternalEnv
, envFunctionNestingLevel = 0
}
where bindings = Map.fromList
[ interfaceBinder "copy" (FuncTy [RefTy (VarTy "a") (VarTy "q")] (VarTy "a") StaticLifetimeTy)
startingTypeEnv =
Env
{ envBindings = bindings,
envParent = Nothing,
envModuleName = Nothing,
envUseModules = [],
envMode = ExternalEnv,
envFunctionNestingLevel = 0
}
where
bindings =
Map.fromList
[ interfaceBinder
"copy"
(FuncTy [RefTy (VarTy "a") (VarTy "q")] (VarTy "a") StaticLifetimeTy)
([SymPath ["Array"] "copy", SymPath ["Pointer"] "copy"] ++ registerFunctionFunctionsWithInterface "copy")
builtInSymbolInfo
, interfaceBinder "str" (FuncTy [VarTy "a"] StringTy StaticLifetimeTy)
builtInSymbolInfo,
interfaceBinder
"str"
(FuncTy [VarTy "a"] StringTy StaticLifetimeTy)
((SymPath ["Array"] "str") : (SymPath ["StaticArray"] "str") : registerFunctionFunctionsWithInterface "str")
builtInSymbolInfo
, interfaceBinder "prn" (FuncTy [VarTy "a"] StringTy StaticLifetimeTy)
builtInSymbolInfo,
interfaceBinder
"prn"
(FuncTy [VarTy "a"] StringTy StaticLifetimeTy)
((SymPath ["StaticArray"] "str") : (registerFunctionFunctionsWithInterface "prn")) -- QUESTION: Where is 'prn' for dynamic Array:s registered? Can't find it... (but it is)
builtInSymbolInfo
]
builtInSymbolInfo = Info (-1) (-1) "Built-in." Set.empty (-1)
]
builtInSymbolInfo = Info (-1) (-1) "Built-in." Set.empty (-1)
-- | Make the functions in the Function.Arity<N> modules register with the interfaces in the type Env.
registerFunctionFunctionsWithInterface :: String -> [SymPath]
registerFunctionFunctionsWithInterface interfaceName =
map (\arity -> SymPath ["Function", "Arity" ++ show arity] interfaceName) [0..maxArity]
map (\arity -> SymPath ["Function", "Arity" ++ show arity] interfaceName) [0 .. maxArity]
-- | Create a binder for an interface definition.
interfaceBinder :: String -> Ty -> [SymPath] -> Info -> (String, Binder)

177
src/StaticArrayTemplates.hs
View File

@ -1,112 +1,129 @@
module StaticArrayTemplates where
import Types
import qualified ArrayTemplates
import Concretize
import Obj
import Template
import ToTemplate
import Concretize
import qualified ArrayTemplates
import Types
-- | NOTE: The code for these templates is copied from ArrayTemplates.hs but
-- since there are some small differences here and there I'v decided to not
-- try to abstract over them and just duplicate the templates instead.
concreteArray :: Ty
concreteArray = (ConcreteNameTy "StaticArray")
templateUnsafeNth :: (String, Binder)
templateUnsafeNth =
let t = VarTy "t"
in defineTemplate
(SymPath ["StaticArray"] "unsafe-nth")
(FuncTy [RefTy (StructTy concreteArray [t]) (VarTy "q"), IntTy] (RefTy t (VarTy "q")) StaticLifetimeTy)
"gets a reference to the `n`th element from a static array `a`."
(toTemplate "$t* $NAME (Array *aRef, int n)")
(toTemplate $ unlines ["$DECL {"
," Array a = *aRef;"
," assert(n >= 0);"
," assert(n < a.len);"
," return &((($t*)a.data)[n]);"
,"}"])
(\(FuncTy [RefTy _ _, _] _ _) ->
[])
in defineTemplate
(SymPath ["StaticArray"] "unsafe-nth")
(FuncTy [RefTy (StructTy concreteArray [t]) (VarTy "q"), IntTy] (RefTy t (VarTy "q")) StaticLifetimeTy)
"gets a reference to the `n`th element from a static array `a`."
(toTemplate "$t* $NAME (Array *aRef, int n)")
( toTemplate $
unlines
[ "$DECL {",
" Array a = *aRef;",
" assert(n >= 0);",
" assert(n < a.len);",
" return &((($t*)a.data)[n]);",
"}"
]
)
( \(FuncTy [RefTy _ _, _] _ _) ->
[]
)
templateLength :: (String, Binder)
templateLength = defineTypeParameterizedTemplate templateCreator path t docs
where path = SymPath ["StaticArray"] "length"
t = FuncTy [RefTy (StructTy concreteArray [VarTy "t"]) (VarTy "q")] IntTy StaticLifetimeTy
docs = "gets the length of the static array."
templateCreator = TemplateCreator $
\typeEnv env ->
Template
t
(const (toTemplate "int $NAME (Array *a)"))
(const (toTemplate "$DECL { return (*a).len; }"))
(\(FuncTy [RefTy arrayType _] _ _) ->
depsForDeleteFunc typeEnv env arrayType)
where
path = SymPath ["StaticArray"] "length"
t = FuncTy [RefTy (StructTy concreteArray [VarTy "t"]) (VarTy "q")] IntTy StaticLifetimeTy
docs = "gets the length of the static array."
templateCreator = TemplateCreator $
\typeEnv env ->
Template
t
(const (toTemplate "int $NAME (Array *a)"))
(const (toTemplate "$DECL { return (*a).len; }"))
( \(FuncTy [RefTy arrayType _] _ _) ->
depsForDeleteFunc typeEnv env arrayType
)
templateDeleteArray :: (String, Binder)
templateDeleteArray = defineTypeParameterizedTemplate templateCreator path t docs
where path = SymPath ["StaticArray"] "delete"
t = FuncTy [StructTy concreteArray [VarTy "a"]] UnitTy StaticLifetimeTy
docs = "deletes a static array. This function should not be called manually (there shouldn't be a way to create value types of type StaticArray)."
templateCreator = TemplateCreator $
\typeEnv env ->
Template
t
(const (toTemplate "void $NAME (Array a)"))
(\(FuncTy [arrayType] UnitTy _) ->
[TokDecl, TokC "{\n"] ++
deleteTy typeEnv env arrayType ++
[TokC "}\n"])
(\(FuncTy [(StructTy _ [insideType])] UnitTy _) ->
depsForDeleteFunc typeEnv env insideType)
where
path = SymPath ["StaticArray"] "delete"
t = FuncTy [StructTy concreteArray [VarTy "a"]] UnitTy StaticLifetimeTy
docs = "deletes a static array. This function should not be called manually (there shouldn't be a way to create value types of type StaticArray)."
templateCreator = TemplateCreator $
\typeEnv env ->
Template
t
(const (toTemplate "void $NAME (Array a)"))
( \(FuncTy [arrayType] UnitTy _) ->
[TokDecl, TokC "{\n"]
++ deleteTy typeEnv env arrayType
++ [TokC "}\n"]
)
( \(FuncTy [(StructTy _ [insideType])] UnitTy _) ->
depsForDeleteFunc typeEnv env insideType
)
deleteTy :: TypeEnv -> Env -> Ty -> [Token]
deleteTy typeEnv env (StructTy _ [innerType]) =
[ TokC " for(int i = 0; i < a.len; i++) {\n"
, TokC $ " " ++ ArrayTemplates.insideArrayDeletion typeEnv env innerType "i"
, TokC " }\n"
[ TokC " for(int i = 0; i < a.len; i++) {\n",
TokC $ " " ++ ArrayTemplates.insideArrayDeletion typeEnv env innerType "i",
TokC " }\n"
]
deleteTy _ _ _ = []
templateAsetBang :: (String, Binder)
templateAsetBang = defineTypeParameterizedTemplate templateCreator path t docs
where path = SymPath ["StaticArray"] "aset!"
t = FuncTy [RefTy (StructTy concreteArray [VarTy "t"]) (VarTy "q"), IntTy, VarTy "t"] UnitTy StaticLifetimeTy
docs = "sets a static array element at the index `n` to a new value in place."
templateCreator = TemplateCreator $
\typeEnv env ->
Template
t
(const (toTemplate "void $NAME (Array *aRef, int n, $t newValue)"))
(\(FuncTy [_, _, insideTy] _ _) ->
let deleter = ArrayTemplates.insideArrayDeletion typeEnv env insideTy
in (toTemplate $ unlines ["$DECL {"
," Array a = *aRef;"
," assert(n >= 0);"
," assert(n < a.len);"
, deleter "n"
," (($t*)a.data)[n] = newValue;"
,"}"]))
(\(FuncTy [RefTy arrayType _, _, _] _ _) ->
depsForDeleteFunc typeEnv env arrayType)
where
path = SymPath ["StaticArray"] "aset!"
t = FuncTy [RefTy (StructTy concreteArray [VarTy "t"]) (VarTy "q"), IntTy, VarTy "t"] UnitTy StaticLifetimeTy
docs = "sets a static array element at the index `n` to a new value in place."
templateCreator = TemplateCreator $
\typeEnv env ->
Template
t
(const (toTemplate "void $NAME (Array *aRef, int n, $t newValue)"))
( \(FuncTy [_, _, insideTy] _ _) ->
let deleter = ArrayTemplates.insideArrayDeletion typeEnv env insideTy
in ( toTemplate $
unlines
[ "$DECL {",
" Array a = *aRef;",
" assert(n >= 0);",
" assert(n < a.len);",
deleter "n",
" (($t*)a.data)[n] = newValue;",
"}"
]
)
)
( \(FuncTy [RefTy arrayType _, _, _] _ _) ->
depsForDeleteFunc typeEnv env arrayType
)
templateStrArray :: (String, Binder)
templateStrArray = defineTypeParameterizedTemplate templateCreator path t docs
where templateCreator = TemplateCreator $
\typeEnv env ->
Template
t
(const (toTemplate "String $NAME (Array* a)"))
(\(FuncTy [RefTy arrayType _] StringTy _) ->
[TokDecl, TokC " {\n"] ++
ArrayTemplates.strTy typeEnv env arrayType ++
[TokC "}\n"])
(\(FuncTy [RefTy (StructTy _ [insideType]) _] StringTy _) ->
depsForPrnFunc typeEnv env insideType)
path = SymPath ["StaticArray"] "str"
t = FuncTy [RefTy (StructTy concreteArray [VarTy "a"]) (VarTy "q")] StringTy StaticLifetimeTy
docs = "converts a static array to a string."
where
templateCreator = TemplateCreator $
\typeEnv env ->
Template
t
(const (toTemplate "String $NAME (Array* a)"))
( \(FuncTy [RefTy arrayType _] StringTy _) ->
[TokDecl, TokC " {\n"]
++ ArrayTemplates.strTy typeEnv env arrayType
++ [TokC "}\n"]
)
( \(FuncTy [RefTy (StructTy _ [insideType]) _] StringTy _) ->
depsForPrnFunc typeEnv env insideType
)
path = SymPath ["StaticArray"] "str"
t = FuncTy [RefTy (StructTy concreteArray [VarTy "a"]) (VarTy "q")] StringTy StaticLifetimeTy
docs = "converts a static array to a string."

86
src/StructUtils.hs
View File

@ -1,14 +1,14 @@
module StructUtils where
import Obj
import Types
import Lookup
import Obj
import Polymorphism
import Types
memberInfo :: TypeEnv -> Ty -> (Ty, String, Ty)
memberInfo typeEnv memberTy =
let refOrNotRefType = if isManaged typeEnv memberTy then RefTy memberTy (VarTy "w") else memberTy -- OBS! The VarTy "w" here is dubious
in (refOrNotRefType, if isManaged typeEnv memberTy then "&" else "", FuncTy [refOrNotRefType] StringTy StaticLifetimeTy)
in (refOrNotRefType, if isManaged typeEnv memberTy then "&" else "", FuncTy [refOrNotRefType] StringTy StaticLifetimeTy)
-- | Generate C code for converting a member variable to a string and appending it to a buffer.
memberPrn :: TypeEnv -> Env -> (String, Ty) -> String
@ -18,45 +18,55 @@ memberPrn typeEnv env (memberName, memberTy) =
Just strFunctionPath ->
case strFuncType of
(FuncTy [UnitTy] _ _) ->
unlines [" temp = " ++ pathToC strFunctionPath ++ "();"
, " sprintf(bufferPtr, \"%s \", temp);"
, " bufferPtr += strlen(temp) + 1;"
, " if(temp) { CARP_FREE(temp); temp = NULL; }"
]
_ -> unlines [" temp = " ++ pathToC strFunctionPath ++ "(" ++ maybeTakeAddress ++ "p->" ++ memberName ++ ");"
, " sprintf(bufferPtr, \"%s \", temp);"
, " bufferPtr += strlen(temp) + 1;"
, " if(temp) { CARP_FREE(temp); temp = NULL; }"
]
unlines
[ " temp = " ++ pathToC strFunctionPath ++ "();",
" sprintf(bufferPtr, \"%s \", temp);",
" bufferPtr += strlen(temp) + 1;",
" if(temp) { CARP_FREE(temp); temp = NULL; }"
]
_ ->
unlines
[ " temp = " ++ pathToC strFunctionPath ++ "(" ++ maybeTakeAddress ++ "p->" ++ memberName ++ ");",
" sprintf(bufferPtr, \"%s \", temp);",
" bufferPtr += strlen(temp) + 1;",
" if(temp) { CARP_FREE(temp); temp = NULL; }"
]
Nothing ->
if isExternalType typeEnv memberTy
then unlines [ " temp = malloc(11);"
, " sprintf(temp, \"<external>\");"
, " sprintf(bufferPtr, \"%s \", temp);"
, " bufferPtr += strlen(temp) + 1;"
, " if(temp) { CARP_FREE(temp); temp = NULL; }"
]
else " // Failed to find str function for " ++ memberName ++ " : " ++ show memberTy ++ "\n"
then
unlines
[ " temp = malloc(11);",
" sprintf(temp, \"<external>\");",
" sprintf(bufferPtr, \"%s \", temp);",
" bufferPtr += strlen(temp) + 1;",
" if(temp) { CARP_FREE(temp); temp = NULL; }"
]
else " // Failed to find str function for " ++ memberName ++ " : " ++ show memberTy ++ "\n"
-- | Calculate the size for prn:ing a member of a struct
memberPrnSize :: TypeEnv -> Env -> (String, Ty) -> String
memberPrnSize typeEnv env (memberName, memberTy) =
let (_, maybeTakeAddress, strFuncType) = memberInfo typeEnv memberTy
in case nameOfPolymorphicFunction typeEnv env strFuncType "prn" of
Just strFunctionPath ->
case strFuncType of
(FuncTy [UnitTy] _ _) ->
unlines [" temp = " ++ pathToC strFunctionPath ++ "(); "
," size += snprintf(NULL, 0, \"%s \", temp);"
," if(temp) { CARP_FREE(temp); temp = NULL; }"
]
_ -> unlines [" temp = " ++ pathToC strFunctionPath ++ "(" ++ maybeTakeAddress ++ "p->" ++ memberName ++ "); "
," size += snprintf(NULL, 0, \"%s \", temp);"
," if(temp) { CARP_FREE(temp); temp = NULL; }"
]
Nothing ->
if isExternalType typeEnv memberTy
then unlines [" size += 11;"
," if(temp) { CARP_FREE(temp); temp = NULL; }"
]
else " // Failed to find str function for " ++ memberName ++ " : " ++ show memberTy ++ "\n"
in case nameOfPolymorphicFunction typeEnv env strFuncType "prn" of
Just strFunctionPath ->
case strFuncType of
(FuncTy [UnitTy] _ _) ->
unlines
[ " temp = " ++ pathToC strFunctionPath ++ "(); ",
" size += snprintf(NULL, 0, \"%s \", temp);",
" if(temp) { CARP_FREE(temp); temp = NULL; }"
]
_ ->
unlines
[ " temp = " ++ pathToC strFunctionPath ++ "(" ++ maybeTakeAddress ++ "p->" ++ memberName ++ "); ",
" size += snprintf(NULL, 0, \"%s \", temp);",
" if(temp) { CARP_FREE(temp); temp = NULL; }"
]
Nothing ->
if isExternalType typeEnv memberTy
then
unlines
[ " size += 11;",
" if(temp) { CARP_FREE(temp); temp = NULL; }"
]
else " // Failed to find str function for " ++ memberName ++ " : " ++ show memberTy ++ "\n"

45
src/SumtypeCase.hs
View File

@ -1,13 +1,16 @@
module SumtypeCase where
import Obj
import Types
import TypeError
import Types
import Validate
data SumtypeCase = SumtypeCase { caseName :: String
, caseTys :: [Ty]
} deriving (Show, Eq)
data SumtypeCase
= SumtypeCase
{ caseName :: String,
caseTys :: [Ty]
}
deriving (Show, Eq)
toCases :: TypeEnv -> [Ty] -> [XObj] -> Either TypeError [SumtypeCase]
toCases typeEnv typeVars xobjs = mapM (toCase typeEnv typeVars) xobjs
@ -15,21 +18,25 @@ toCases typeEnv typeVars xobjs = mapM (toCase typeEnv typeVars) xobjs
toCase :: TypeEnv -> [Ty] -> XObj -> Either TypeError SumtypeCase
toCase typeEnv typeVars x@(XObj (Lst [XObj (Sym (SymPath [] name) Symbol) _ _, XObj (Arr tyXObjs) _ _]) _ _) =
let tys = map xobjToTy tyXObjs
in case sequence tys of
Nothing ->
Left (InvalidSumtypeCase x)
Just okTys ->
let validated = map (\t -> canBeUsedAsMemberType typeEnv typeVars t x) okTys
in case sequence validated of
Left e ->
Left e
Right _ ->
Right $ SumtypeCase { caseName = name
, caseTys = okTys
}
toCase _ _ (XObj (Sym (SymPath [] name) Symbol) _ _) =
Right $ SumtypeCase { caseName = name
, caseTys = []
in case sequence tys of
Nothing ->
Left (InvalidSumtypeCase x)
Just okTys ->
let validated = map (\t -> canBeUsedAsMemberType typeEnv typeVars t x) okTys
in case sequence validated of
Left e ->
Left e
Right _ ->
Right $
SumtypeCase
{ caseName = name,
caseTys = okTys
}
toCase _ _ (XObj (Sym (SymPath [] name) Symbol) _ _) =
Right $
SumtypeCase
{ caseName = name,
caseTys = []
}
toCase _ _ x =
Left (InvalidSumtypeCase x)

476
src/Sumtypes.hs
View File

@ -1,21 +1,20 @@
module Sumtypes where
import Concretize
import qualified Data.Map as Map
import Data.Maybe
import Deftype
import Info
import Lookup
import Obj
import StructUtils
import SumtypeCase
import Template
import ToTemplate
import TypeError
import Types
import TypesToC
import Util
import Concretize
import Lookup
import Template
import ToTemplate
import Deftype
import StructUtils
import TypeError
import SumtypeCase
import Info
getCase :: [SumtypeCase] -> String -> Maybe SumtypeCase
getCase cases caseNameToFind =
@ -28,7 +27,8 @@ moduleForSumtype innerEnv typeEnv env pathStrings typeName typeVariables rest i
let typeModuleName = typeName
typeModuleEnv = fromMaybe (Env (Map.fromList []) (Just innerEnv) (Just typeModuleName) [] ExternalEnv 0) existingEnv
insidePath = pathStrings ++ [typeModuleName]
in do let structTy = StructTy (ConcreteNameTy typeName) typeVariables
in do
let structTy = StructTy (ConcreteNameTy typeName) typeVariables
cases <- toCases typeEnv typeVariables rest
okIniters <- initers insidePath structTy cases
okTag <- binderForTag insidePath structTy
@ -47,9 +47,10 @@ memberDeps typeEnv cases = fmap concat (mapM (concretizeType typeEnv) (concatMap
replaceGenericTypesOnCases :: TypeMappings -> [SumtypeCase] -> [SumtypeCase]
replaceGenericTypesOnCases mappings cases =
map replaceOnCase cases
where replaceOnCase theCase =
let newTys = (map (replaceTyVars mappings) (caseTys theCase))
in theCase { caseTys = newTys }
where
replaceOnCase theCase =
let newTys = (map (replaceTyVars mappings) (caseTys theCase))
in theCase {caseTys = newTys}
initers :: [String] -> Ty -> [SumtypeCase] -> Either TypeError [(String, Binder)]
initers insidePath structTy cases = mapM (binderForCaseInit insidePath structTy) cases
@ -57,291 +58,348 @@ initers insidePath structTy cases = mapM (binderForCaseInit insidePath structTy)
binderForCaseInit :: [String] -> Ty -> SumtypeCase -> Either TypeError (String, Binder)
binderForCaseInit insidePath structTy@(StructTy (ConcreteNameTy _) _) sumtypeCase =
if isTypeGeneric structTy
then Right (genericCaseInit StackAlloc insidePath structTy sumtypeCase)
else Right (concreteCaseInit StackAlloc insidePath structTy sumtypeCase)
then Right (genericCaseInit StackAlloc insidePath structTy sumtypeCase)
else Right (concreteCaseInit StackAlloc insidePath structTy sumtypeCase)
concreteCaseInit :: AllocationMode -> [String] -> Ty -> SumtypeCase -> (String, Binder)
concreteCaseInit allocationMode insidePath structTy sumtypeCase =
instanceBinder (SymPath insidePath (caseName sumtypeCase)) (FuncTy (caseTys sumtypeCase) structTy StaticLifetimeTy) template doc
where doc = "creates a `" ++ caseName sumtypeCase ++ "`."
template =
Template
(FuncTy (caseTys sumtypeCase) (VarTy "p") StaticLifetimeTy)
(\(FuncTy _ concreteStructTy _) ->
let mappings = unifySignatures structTy concreteStructTy
correctedTys = map (replaceTyVars mappings) (caseTys sumtypeCase)
in (toTemplate $ "$p $NAME(" ++ joinWithComma (zipWith (curry memberArg) anonMemberNames (remove isUnit correctedTys)) ++ ")"))
(const (tokensForCaseInit allocationMode structTy sumtypeCase))
(\FuncTy{} -> [])
where
doc = "creates a `" ++ caseName sumtypeCase ++ "`."
template =
Template
(FuncTy (caseTys sumtypeCase) (VarTy "p") StaticLifetimeTy)
( \(FuncTy _ concreteStructTy _) ->
let mappings = unifySignatures structTy concreteStructTy
correctedTys = map (replaceTyVars mappings) (caseTys sumtypeCase)
in (toTemplate $ "$p $NAME(" ++ joinWithComma (zipWith (curry memberArg) anonMemberNames (remove isUnit correctedTys)) ++ ")")
)
(const (tokensForCaseInit allocationMode structTy sumtypeCase))
(\FuncTy {} -> [])
genericCaseInit :: AllocationMode -> [String] -> Ty -> SumtypeCase -> (String, Binder)
genericCaseInit allocationMode pathStrings originalStructTy sumtypeCase =
defineTypeParameterizedTemplate templateCreator path t docs
where path = SymPath pathStrings (caseName sumtypeCase)
t = FuncTy (caseTys sumtypeCase) originalStructTy StaticLifetimeTy
docs = "creates a `" ++ caseName sumtypeCase ++ "`."
templateCreator = TemplateCreator $
\typeEnv _ ->
Template
(FuncTy (caseTys sumtypeCase) (VarTy "p") StaticLifetimeTy)
(\(FuncTy _ concreteStructTy _) ->
let mappings = unifySignatures originalStructTy concreteStructTy
correctedTys = map (replaceTyVars mappings) (caseTys sumtypeCase)
in toTemplate $ "$p $NAME(" ++ joinWithComma (zipWith (curry memberArg) anonMemberNames (remove isUnit correctedTys)) ++ ")")
(\(FuncTy _ concreteStructTy _) ->
let mappings = unifySignatures originalStructTy concreteStructTy
correctedTys = map (replaceTyVars mappings) (caseTys sumtypeCase)
in tokensForCaseInit allocationMode concreteStructTy (sumtypeCase {caseTys = correctedTys}))
(\(FuncTy _ concreteStructTy _) ->
case concretizeType typeEnv concreteStructTy of
Left err -> error (show err ++ ". This error should not crash the compiler - change return type to Either here.")
Right ok -> ok)
where
path = SymPath pathStrings (caseName sumtypeCase)
t = FuncTy (caseTys sumtypeCase) originalStructTy StaticLifetimeTy
docs = "creates a `" ++ caseName sumtypeCase ++ "`."
templateCreator = TemplateCreator $
\typeEnv _ ->
Template
(FuncTy (caseTys sumtypeCase) (VarTy "p") StaticLifetimeTy)
( \(FuncTy _ concreteStructTy _) ->
let mappings = unifySignatures originalStructTy concreteStructTy
correctedTys = map (replaceTyVars mappings) (caseTys sumtypeCase)
in toTemplate $ "$p $NAME(" ++ joinWithComma (zipWith (curry memberArg) anonMemberNames (remove isUnit correctedTys)) ++ ")"
)
( \(FuncTy _ concreteStructTy _) ->
let mappings = unifySignatures originalStructTy concreteStructTy
correctedTys = map (replaceTyVars mappings) (caseTys sumtypeCase)
in tokensForCaseInit allocationMode concreteStructTy (sumtypeCase {caseTys = correctedTys})
)
( \(FuncTy _ concreteStructTy _) ->
case concretizeType typeEnv concreteStructTy of
Left err -> error (show err ++ ". This error should not crash the compiler - change return type to Either here.")
Right ok -> ok
)
tokensForCaseInit :: AllocationMode -> Ty -> SumtypeCase -> [Token]
tokensForCaseInit allocationMode sumTy@(StructTy (ConcreteNameTy typeName) _) sumtypeCase =
toTemplate $ unlines [ "$DECL {"
, case allocationMode of
StackAlloc -> " $p instance;"
HeapAlloc -> " $p instance = CARP_MALLOC(sizeof(" ++ typeName ++ "));"
, joinLines $ caseMemberAssignment allocationMode correctedName . fst <$> unitless
, " instance._tag = " ++ tagName sumTy correctedName ++ ";"
, " return instance;"
, "}"]
where correctedName = caseName sumtypeCase
unitless = zip anonMemberNames $ remove isUnit (caseTys sumtypeCase)
toTemplate $
unlines
[ "$DECL {",
case allocationMode of
StackAlloc -> " $p instance;"
HeapAlloc -> " $p instance = CARP_MALLOC(sizeof(" ++ typeName ++ "));",
joinLines $ caseMemberAssignment allocationMode correctedName . fst <$> unitless,
" instance._tag = " ++ tagName sumTy correctedName ++ ";",
" return instance;",
"}"
]
where
correctedName = caseName sumtypeCase
unitless = zip anonMemberNames $ remove isUnit (caseTys sumtypeCase)
caseMemberAssignment :: AllocationMode -> String -> String -> String
caseMemberAssignment allocationMode caseNm memberName =
" instance" ++ sep ++ caseNm ++ "." ++ memberName ++ " = " ++ memberName ++ ";"
where sep = case allocationMode of
StackAlloc -> ".u."
HeapAlloc -> "->u."
where
sep = case allocationMode of
StackAlloc -> ".u."
HeapAlloc -> "->u."
binderForTag :: [String] -> Ty -> Either TypeError (String, Binder)
binderForTag insidePath originalStructTy@(StructTy (ConcreteNameTy typeName) _) =
Right $ instanceBinder path (FuncTy [RefTy originalStructTy (VarTy "q")] IntTy StaticLifetimeTy) template doc
where path = SymPath insidePath "get-tag"
template = Template
(FuncTy [RefTy originalStructTy (VarTy "q")] IntTy StaticLifetimeTy)
(\(FuncTy [RefTy structTy _] IntTy _) -> toTemplate $ proto structTy)
(\(FuncTy [RefTy structTy _] IntTy _) -> toTemplate $ proto structTy ++ " { return p->_tag; }")
(\_ -> [])
proto structTy = "int $NAME(" ++ tyToCLambdaFix structTy ++ " *p)"
doc = "Gets the tag from a `" ++ typeName ++ "`."
where
path = SymPath insidePath "get-tag"
template =
Template
(FuncTy [RefTy originalStructTy (VarTy "q")] IntTy StaticLifetimeTy)
(\(FuncTy [RefTy structTy _] IntTy _) -> toTemplate $ proto structTy)
(\(FuncTy [RefTy structTy _] IntTy _) -> toTemplate $ proto structTy ++ " { return p->_tag; }")
(\_ -> [])
proto structTy = "int $NAME(" ++ tyToCLambdaFix structTy ++ " *p)"
doc = "Gets the tag from a `" ++ 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 _) _) cases strOrPrn =
Right $ if isTypeGeneric structTy
then (genericStr insidePath structTy cases strOrPrn, [])
else concreteStr typeEnv env insidePath structTy cases strOrPrn
Right $
if isTypeGeneric structTy
then (genericStr insidePath structTy cases strOrPrn, [])
else concreteStr typeEnv env insidePath structTy cases strOrPrn
-- | The template for the 'str' function for a concrete deftype.
concreteStr :: TypeEnv -> Env -> [String] -> Ty -> [SumtypeCase] -> String -> ((String, Binder), [XObj])
concreteStr typeEnv env insidePath concreteStructTy@(StructTy (ConcreteNameTy typeName) _) cases strOrPrn =
instanceBinderWithDeps (SymPath insidePath strOrPrn) (FuncTy [RefTy concreteStructTy (VarTy "q")] StringTy StaticLifetimeTy) template doc
where doc = "converts a `" ++ typeName ++ "` to a string."
template =
Template
(FuncTy [RefTy concreteStructTy (VarTy "q")] StringTy StaticLifetimeTy)
(\(FuncTy [RefTy structTy _] StringTy _) -> toTemplate $ "String $NAME(" ++ tyToCLambdaFix structTy ++ " *p)")
(\(FuncTy [RefTy (StructTy _ _) _] StringTy _) ->
tokensForStr typeEnv env typeName cases concreteStructTy)
(\(FuncTy [RefTy (StructTy _ _) _] StringTy _) ->
concatMap (depsOfPolymorphicFunction typeEnv env [] "prn" . typesStrFunctionType typeEnv)
(filter (\t -> (not . isExternalType typeEnv) t && (not . isFullyGenericType) t) (concatMap caseTys cases))
)
where
doc = "converts a `" ++ typeName ++ "` to a string."
template =
Template
(FuncTy [RefTy concreteStructTy (VarTy "q")] StringTy StaticLifetimeTy)
(\(FuncTy [RefTy structTy _] StringTy _) -> toTemplate $ "String $NAME(" ++ tyToCLambdaFix structTy ++ " *p)")
( \(FuncTy [RefTy (StructTy _ _) _] StringTy _) ->
tokensForStr typeEnv env typeName cases concreteStructTy
)
( \(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) _) cases strOrPrn =
defineTypeParameterizedTemplate templateCreator path t docs
where path = SymPath insidePath strOrPrn
t = FuncTy [RefTy originalStructTy (VarTy "q")] StringTy StaticLifetimeTy
docs = "stringifies a `" ++ show typeName ++ "`."
templateCreator = TemplateCreator $
\typeEnv env ->
Template
t
(\(FuncTy [RefTy concreteStructTy _] StringTy _) ->
toTemplate $ "String $NAME(" ++ tyToCLambdaFix concreteStructTy ++ " *p)")
(\(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 _ _) _] StringTy _) ->
let mappings = unifySignatures originalStructTy concreteStructTy
correctedCases = replaceGenericTypesOnCases mappings cases
tys = filter (\t' -> (not . isExternalType typeEnv) t' && (not . isFullyGenericType) t') (concatMap caseTys correctedCases)
in concatMap (depsOfPolymorphicFunction typeEnv env [] "prn" . typesStrFunctionType typeEnv) tys
++
(if isTypeGeneric concreteStructTy then [] else [defineFunctionTypeAlias ft]))
where
path = SymPath insidePath strOrPrn
t = FuncTy [RefTy originalStructTy (VarTy "q")] StringTy StaticLifetimeTy
docs = "stringifies a `" ++ show typeName ++ "`."
templateCreator = TemplateCreator $
\typeEnv env ->
Template
t
( \(FuncTy [RefTy concreteStructTy _] StringTy _) ->
toTemplate $ "String $NAME(" ++ tyToCLambdaFix concreteStructTy ++ " *p)"
)
( \(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 _ _) _] StringTy _) ->
let mappings = unifySignatures originalStructTy concreteStructTy
correctedCases = replaceGenericTypesOnCases mappings cases
tys = filter (\t' -> (not . isExternalType typeEnv) t' && (not . isFullyGenericType) t') (concatMap caseTys correctedCases)
in concatMap (depsOfPolymorphicFunction typeEnv env [] "prn" . typesStrFunctionType typeEnv) tys
++ (if isTypeGeneric concreteStructTy then [] else [defineFunctionTypeAlias ft])
)
tokensForStr :: TypeEnv -> Env -> String -> [SumtypeCase] -> Ty -> [Token]
tokensForStr typeEnv env _ cases concreteStructTy =
toTemplate $ unlines [ "$DECL {"
, " // convert members to String here:"
, " String temp = NULL;"
, " int tempsize = 0;"
, " (void)tempsize; // that way we remove the occasional unused warning "
, calculateStructStrSize typeEnv env cases concreteStructTy
, " String buffer = CARP_MALLOC(size);"
, " String bufferPtr = buffer;"
, ""
, concatMap (strCase typeEnv env concreteStructTy) cases
, " return buffer;"
, "}"]
tokensForStr typeEnv env _ cases concreteStructTy =
toTemplate $
unlines
[ "$DECL {",
" // convert members to String here:",
" String temp = NULL;",
" int tempsize = 0;",
" (void)tempsize; // that way we remove the occasional unused warning ",
calculateStructStrSize typeEnv env cases concreteStructTy,
" String buffer = CARP_MALLOC(size);",
" String bufferPtr = buffer;",
"",
concatMap (strCase typeEnv env concreteStructTy) cases,
" return buffer;",
"}"
]
namesFromCase :: SumtypeCase -> Ty -> (String, [Ty], String)
namesFromCase theCase concreteStructTy =
let name = caseName theCase
in (name, caseTys theCase {caseTys = (remove isUnit (caseTys theCase))}, tagName concreteStructTy name)
in (name, caseTys theCase {caseTys = (remove isUnit (caseTys theCase))}, tagName concreteStructTy name)
strCase :: TypeEnv -> Env -> Ty -> SumtypeCase -> String
strCase typeEnv env concreteStructTy@(StructTy _ _) theCase =
let (name, tys, correctedTagName) = namesFromCase theCase concreteStructTy
in unlines
[ " if(p->_tag == " ++ correctedTagName ++ ") {"
, " sprintf(bufferPtr, \"(%s \", \"" ++ name ++ "\");"
, " bufferPtr += strlen(\"" ++ name ++ "\") + 2;\n"
, joinLines $ memberPrn typeEnv env <$> unionMembers name tys
, " bufferPtr--;"
, " sprintf(bufferPtr, \")\");"
, " }"
]
in unlines
[ " if(p->_tag == " ++ correctedTagName ++ ") {",
" sprintf(bufferPtr, \"(%s \", \"" ++ name ++ "\");",
" bufferPtr += strlen(\"" ++ name ++ "\") + 2;\n",
joinLines $ memberPrn typeEnv env <$> unionMembers name tys,
" bufferPtr--;",
" sprintf(bufferPtr, \")\");",
" }"
]
-- | 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 _) _) =
" int size = 1;\n" ++
concatMap (strSizeCase typeEnv env structTy) cases
" int size = 1;\n"
++ concatMap (strSizeCase typeEnv env structTy) cases
strSizeCase :: TypeEnv -> Env -> Ty -> SumtypeCase -> String
strSizeCase typeEnv env concreteStructTy@(StructTy _ _) theCase =
let (name, tys, correctedTagName) = namesFromCase theCase concreteStructTy
in unlines
[ " if(p->_tag == " ++ correctedTagName ++ ") {"
, " size += snprintf(NULL, 0, \"(%s \", \"" ++ name ++ "\");"
, joinLines $ memberPrnSize typeEnv env <$> unionMembers name tys
, " }"
]
in unlines
[ " if(p->_tag == " ++ correctedTagName ++ ") {",
" size += snprintf(NULL, 0, \"(%s \", \"" ++ name ++ "\");",
joinLines $ memberPrnSize typeEnv env <$> unionMembers name tys,
" }"
]
-- | 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 _) _) cases =
Right $ if isTypeGeneric structTy
then genericSumtypeDelete insidePath structTy cases
else concreteSumtypeDelete insidePath typeEnv env structTy cases
Right $
if isTypeGeneric structTy
then genericSumtypeDelete insidePath structTy cases
else concreteSumtypeDelete insidePath typeEnv env structTy cases
-- | The template for the 'delete' function of a generic sumtype.
genericSumtypeDelete :: [String] -> Ty -> [SumtypeCase] -> (String, Binder)
genericSumtypeDelete pathStrings originalStructTy cases =
defineTypeParameterizedTemplate templateCreator path (FuncTy [originalStructTy] UnitTy StaticLifetimeTy) docs
where path = SymPath pathStrings "delete"
t = FuncTy [VarTy "p"] UnitTy StaticLifetimeTy
docs = "deletes a `" ++ show originalStructTy ++ "`. Should usually not be called manually."
templateCreator = TemplateCreator $
\typeEnv env ->
Template
t
(const (toTemplate "void $NAME($p p)"))
(\(FuncTy [concreteStructTy] UnitTy _) ->
let mappings = unifySignatures originalStructTy concreteStructTy
correctedCases = replaceGenericTypesOnCases mappings cases
in (toTemplate $ unlines [ "$DECL {"
, concatMap (deleteCase typeEnv env concreteStructTy) (zip correctedCases (True : repeat False))
, "}"]))
(\(FuncTy [concreteStructTy] UnitTy _) ->
let mappings = unifySignatures originalStructTy concreteStructTy
correctedCases = replaceGenericTypesOnCases mappings cases
in if isTypeGeneric concreteStructTy
then []
else concatMap (depsOfPolymorphicFunction typeEnv env [] "delete" . typesDeleterFunctionType)
(filter (isManaged typeEnv) (concatMap caseTys correctedCases)))
where
path = SymPath pathStrings "delete"
t = FuncTy [VarTy "p"] UnitTy StaticLifetimeTy
docs = "deletes a `" ++ show originalStructTy ++ "`. Should usually not be called manually."
templateCreator = TemplateCreator $
\typeEnv env ->
Template
t
(const (toTemplate "void $NAME($p p)"))
( \(FuncTy [concreteStructTy] UnitTy _) ->
let mappings = unifySignatures originalStructTy concreteStructTy
correctedCases = replaceGenericTypesOnCases mappings cases
in ( toTemplate $
unlines
[ "$DECL {",
concatMap (deleteCase typeEnv env concreteStructTy) (zip correctedCases (True : repeat False)),
"}"
]
)
)
( \(FuncTy [concreteStructTy] UnitTy _) ->
let mappings = unifySignatures originalStructTy concreteStructTy
correctedCases = replaceGenericTypesOnCases mappings cases
in if isTypeGeneric concreteStructTy
then []
else
concatMap
(depsOfPolymorphicFunction typeEnv env [] "delete" . typesDeleterFunctionType)
(filter (isManaged typeEnv) (concatMap caseTys correctedCases))
)
-- | The template for the 'delete' function of a concrete sumtype
concreteSumtypeDelete :: [String] -> TypeEnv -> Env -> Ty -> [SumtypeCase] -> (String, Binder)
concreteSumtypeDelete insidePath typeEnv env structTy@(StructTy (ConcreteNameTy typeName) _) cases =
instanceBinder (SymPath insidePath "delete") (FuncTy [structTy] UnitTy StaticLifetimeTy) template doc
where doc = "deletes a `" ++ typeName ++ "`. This should usually not be called manually."
template = Template
(FuncTy [VarTy "p"] UnitTy StaticLifetimeTy)
(const (toTemplate "void $NAME($p p)"))
(const (toTemplate $ unlines [ "$DECL {"
, concatMap (deleteCase typeEnv env structTy) (zip cases (True : repeat False))
, "}"]))
(\_ -> concatMap (depsOfPolymorphicFunction typeEnv env [] "delete" . typesDeleterFunctionType)
(filter (isManaged typeEnv) (concatMap caseTys cases)))
where
doc = "deletes a `" ++ typeName ++ "`. This should usually not be called manually."
template =
Template
(FuncTy [VarTy "p"] UnitTy StaticLifetimeTy)
(const (toTemplate "void $NAME($p p)"))
( const
( toTemplate $
unlines
[ "$DECL {",
concatMap (deleteCase typeEnv env structTy) (zip cases (True : repeat False)),
"}"
]
)
)
( \_ ->
concatMap
(depsOfPolymorphicFunction typeEnv env [] "delete" . typesDeleterFunctionType)
(filter (isManaged typeEnv) (concatMap caseTys cases))
)
deleteCase :: TypeEnv -> Env -> Ty -> (SumtypeCase, Bool) -> String
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 ++ ") {"
, joinLines $ memberDeletion typeEnv env <$> unionMembers name tys
, " }"
]
in unlines
[ " " ++ (if isFirstCase then "" else "else ") ++ "if(p._tag == " ++ correctedTagName ++ ") {",
joinLines $ memberDeletion typeEnv env <$> unionMembers name tys,
" }"
]
-- | 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 _) _) cases =
Right $ if isTypeGeneric structTy
then (genericSumtypeCopy insidePath structTy cases, [])
else concreteSumtypeCopy insidePath typeEnv env structTy cases
Right $
if isTypeGeneric structTy
then (genericSumtypeCopy insidePath structTy cases, [])
else concreteSumtypeCopy insidePath typeEnv env structTy cases
-- | The template for the 'copy' function of a generic sumtype.
genericSumtypeCopy :: [String] -> Ty -> [SumtypeCase] -> (String, Binder)
genericSumtypeCopy pathStrings originalStructTy cases =
defineTypeParameterizedTemplate templateCreator path (FuncTy [RefTy originalStructTy (VarTy "q")] originalStructTy StaticLifetimeTy) docs
where path = SymPath pathStrings "copy"
t = FuncTy [RefTy (VarTy "p") (VarTy "q")] (VarTy "p") StaticLifetimeTy
docs = "copies a `" ++ show originalStructTy ++ "`."
templateCreator = TemplateCreator $
\typeEnv env ->
Template
t
(const (toTemplate "$p $NAME($p* pRef)"))
(\(FuncTy [RefTy concreteStructTy _] _ _) ->
let mappings = unifySignatures originalStructTy concreteStructTy
correctedCases = replaceGenericTypesOnCases mappings cases
in tokensForSumtypeCopy typeEnv env concreteStructTy correctedCases)
(\(FuncTy [RefTy concreteStructTy _] _ _) ->
let mappings = unifySignatures originalStructTy concreteStructTy
correctedCases = replaceGenericTypesOnCases mappings cases
in if isTypeGeneric concreteStructTy
then []
else concatMap (depsOfPolymorphicFunction typeEnv env [] "copy" . typesCopyFunctionType)
(filter (isManaged typeEnv) (concatMap caseTys correctedCases)))
where
path = SymPath pathStrings "copy"
t = FuncTy [RefTy (VarTy "p") (VarTy "q")] (VarTy "p") StaticLifetimeTy
docs = "copies a `" ++ show originalStructTy ++ "`."
templateCreator = TemplateCreator $
\typeEnv env ->
Template
t
(const (toTemplate "$p $NAME($p* pRef)"))
( \(FuncTy [RefTy concreteStructTy _] _ _) ->
let mappings = unifySignatures originalStructTy concreteStructTy
correctedCases = replaceGenericTypesOnCases mappings cases
in tokensForSumtypeCopy typeEnv env concreteStructTy correctedCases
)
( \(FuncTy [RefTy concreteStructTy _] _ _) ->
let mappings = unifySignatures originalStructTy concreteStructTy
correctedCases = replaceGenericTypesOnCases mappings cases
in if isTypeGeneric concreteStructTy
then []
else
concatMap
(depsOfPolymorphicFunction typeEnv env [] "copy" . typesCopyFunctionType)
(filter (isManaged typeEnv) (concatMap caseTys correctedCases))
)
-- | The template for the 'copy' function of a concrete sumtype
concreteSumtypeCopy :: [String] -> TypeEnv -> Env -> Ty -> [SumtypeCase] -> ((String, Binder), [XObj])
concreteSumtypeCopy insidePath typeEnv env structTy@(StructTy (ConcreteNameTy typeName) _) cases =
instanceBinderWithDeps (SymPath insidePath "copy") (FuncTy [RefTy structTy (VarTy "q")] structTy StaticLifetimeTy) template doc
where doc = "copies a `" ++ typeName ++ "`."
template = Template
(FuncTy [RefTy (VarTy "p") (VarTy "q")] (VarTy "p") StaticLifetimeTy)
(const (toTemplate "$p $NAME($p* pRef)"))
(const (tokensForSumtypeCopy typeEnv env structTy cases))
(\_ -> concatMap (depsOfPolymorphicFunction typeEnv env [] "copy" . typesCopyFunctionType)
(filter (isManaged typeEnv) (concatMap caseTys cases)))
where
doc = "copies a `" ++ typeName ++ "`."
template =
Template
(FuncTy [RefTy (VarTy "p") (VarTy "q")] (VarTy "p") StaticLifetimeTy)
(const (toTemplate "$p $NAME($p* pRef)"))
(const (tokensForSumtypeCopy typeEnv env structTy cases))
( \_ ->
concatMap
(depsOfPolymorphicFunction typeEnv env [] "copy" . typesCopyFunctionType)
(filter (isManaged typeEnv) (concatMap caseTys cases))
)
tokensForSumtypeCopy :: TypeEnv -> Env -> Ty -> [SumtypeCase] -> [Token]
tokensForSumtypeCopy typeEnv env concreteStructTy cases =
toTemplate $ unlines [ "$DECL {"
, " $p copy = *pRef;"
, joinLines $ map (copyCase typeEnv env concreteStructTy) (zip cases (True : repeat False))
, " return copy;"
, "}"]
toTemplate $
unlines
[ "$DECL {",
" $p copy = *pRef;",
joinLines $ map (copyCase typeEnv env concreteStructTy) (zip cases (True : repeat False)),
" return copy;",
"}"
]
copyCase :: TypeEnv -> Env -> Ty -> (SumtypeCase, Bool) -> String
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 ++ ") {"
, joinLines $ memberCopy typeEnv env <$> unionMembers name tys
, " }"
]
in unlines
[ " " ++ (if isFirstCase then "" else "else ") ++ "if(pRef->_tag == " ++ correctedTagName ++ ") {",
joinLines $ memberCopy typeEnv env <$> unionMembers name tys,
" }"
]
anonMemberName :: String -> String -> String
anonMemberName name anon = "u." ++ name ++ "." ++ anon

113
src/SymPath.hs
View File

@ -1,10 +1,13 @@
module SymPath (SymPath(..)
, mangle
, pathToC
, consPath) where
module SymPath
( SymPath (..),
mangle,
pathToC,
consPath,
)
where
import qualified Data.Map as Map
import Data.Char (isAscii, ord)
import qualified Data.Map as Map
import Util
-- | The path to a binding
@ -13,54 +16,64 @@ data SymPath = SymPath [String] String deriving (Ord, Eq)
instance Show SymPath where
show (SymPath modulePath symName) =
if null modulePath
then symName
else joinWithPeriod modulePath ++ "." ++ symName
then symName
else joinWithPeriod modulePath ++ "." ++ symName
-- | Replaces symbols not allowed in C-identifiers.
mangle :: String -> String
mangle = ureplace . sreplace . creplace
where creplace = replaceChars (Map.fromList [('+', "_PLUS_")
,('-', "_MINUS_")
,('*', "_MUL_")
,('/', "_DIV_")
,('<', "_LT_")
,('>', "_GT_")
,('?', "_QMARK_")
,('!', "_BANG_")
,('=', "_EQ_")])
sreplace = replaceStrings (Map.fromList [("auto", "_AUTO_")
,("break", "_BREAK_")
,("case", "_CASE_")
,("const", "_CONST_")
,("char", "_CHAR_")
,("continue", "_CONTINUE_")
,("default", "_DEFAULT_")
,("do", "_DO_")
,("double", "_DOUBLE_")
,("else", "_ELSE_")
,("enum", "_ENUM_")
,("extern", "_EXTERN")
,("float", "_FLOAT_")
,("for", "_FOR")
,("goto", "_GOTO_")
,("if", "_IF_")
,("int", "_INT_")
,("long", "_LONG_")
,("register", "_REGISTER_")
,("return", "_RETURN_")
,("short", "_SHORT_")
,("signed", "_SIGNED_")
,("sizeof", "_SIZEOF_")
,("static", "_STATIC_")
,("struct", "_STRUCT_")
,("switch", "_SWITCH_")
,("typedef", "_TYPEDEF_")
,("union", "_UNION_")
,("unsigned", "_UNSIGNED_")
,("volatile", "_VOLATILE_")
,("void", "_VOID_")
,("while", "_WHILE_")])
ureplace = concatMap (\c -> if isAscii c then pure c else "_U" ++ show (ord c) ++ "U_")
where
creplace =
replaceChars
( Map.fromList
[ ('+', "_PLUS_"),
('-', "_MINUS_"),
('*', "_MUL_"),
('/', "_DIV_"),
('<', "_LT_"),
('>', "_GT_"),
('?', "_QMARK_"),
('!', "_BANG_"),
('=', "_EQ_")
]
)
sreplace =
replaceStrings
( Map.fromList
[ ("auto", "_AUTO_"),
("break", "_BREAK_"),
("case", "_CASE_"),
("const", "_CONST_"),
("char", "_CHAR_"),
("continue", "_CONTINUE_"),
("default", "_DEFAULT_"),
("do", "_DO_"),
("double", "_DOUBLE_"),
("else", "_ELSE_"),
("enum", "_ENUM_"),
("extern", "_EXTERN"),
("float", "_FLOAT_"),
("for", "_FOR"),
("goto", "_GOTO_"),
("if", "_IF_"),
("int", "_INT_"),
("long", "_LONG_"),
("register", "_REGISTER_"),
("return", "_RETURN_"),
("short", "_SHORT_"),
("signed", "_SIGNED_"),
("sizeof", "_SIZEOF_"),
("static", "_STATIC_"),
("struct", "_STRUCT_"),
("switch", "_SWITCH_"),
("typedef", "_TYPEDEF_"),
("union", "_UNION_"),
("unsigned", "_UNSIGNED_"),
("volatile", "_VOLATILE_"),
("void", "_VOID_"),
("while", "_WHILE_")
]
)
ureplace = concatMap (\c -> if isAscii c then pure c else "_U" ++ show (ord c) ++ "U_")
pathToC :: SymPath -> String
pathToC (SymPath modulePath name) =

58
src/Template.hs
View File

@ -1,13 +1,12 @@
module Template where
import qualified Data.Set as Set
import Util
import Types
import Obj
import ToTemplate
import Info
import qualified Meta
import Obj
import ToTemplate
import Types
import Util
-- | Create a binding pair used for adding a template instantiation to an environment.
instanceBinder :: SymPath -> Ty -> Template -> String -> (String, Binder)
@ -15,7 +14,7 @@ instanceBinder path@(SymPath _ name) actualType template docs =
let (x, _) = instantiateTemplate path actualType template
docObj = XObj (Str docs) (Just dummyInfo) Nothing
meta = Meta.set "doc" docObj emptyMeta
in (name, Binder meta x)
in (name, Binder meta x)
-- | Create a binding pair and don't discard the dependencies
instanceBinderWithDeps :: SymPath -> Ty -> Template -> String -> ((String, Binder), [XObj])
@ -23,7 +22,7 @@ instanceBinderWithDeps path@(SymPath _ name) actualType template docs =
let (x, deps) = instantiateTemplate path actualType template
docObj = XObj (Str docs) (Just dummyInfo) Nothing
meta = Meta.set "doc" docObj emptyMeta
in ((name, Binder meta x), deps)
in ((name, Binder meta x), deps)
-- | Templates are instructions for the compiler to generate some C-code
-- | based on some template and the names and types to fill into the template.
@ -44,7 +43,7 @@ defineTemplate path t docs declaration definition depsFunc =
defLst = [XObj (Deftemplate (TemplateCreator (\_ _ -> template))) Nothing Nothing, XObj (Sym path Symbol) Nothing Nothing]
docObj = XObj (Str docs) (Just dummyInfo) Nothing
meta = Meta.set "doc" docObj emptyMeta
in (name, Binder meta (XObj (Lst defLst) (Just i) (Just t)))
in (name, Binder meta (XObj (Lst defLst) (Just i) (Just t)))
-- | The more advanced version of a template, where the code can vary depending on the type.
defineTypeParameterizedTemplate :: TemplateCreator -> SymPath -> Ty -> String -> (String, Binder)
@ -54,7 +53,7 @@ defineTypeParameterizedTemplate templateCreator path t docs =
defLst = [XObj (Deftemplate templateCreator) Nothing Nothing, XObj (Sym path Symbol) Nothing Nothing]
docObj = XObj (Str docs) (Just dummyInfo) Nothing
meta = Meta.set "doc" docObj emptyMeta
in (name, Binder meta (XObj (Lst defLst) (Just i) (Just t)))
in (name, Binder meta (XObj (Lst defLst) (Just i) (Just t)))
-- | Concretizes the types used in @token
-- @cName is the name of the definition, i.e. the "foo" in "void foo() { ... }"
@ -72,27 +71,42 @@ templateCodeForCallingLambda functionName t args =
let FuncTy argTys retTy lt = t
castToFnWithEnv = tyToCast (FuncTy (lambdaEnvTy : argTys) retTy lt)
castToFn = tyToCast t
in
functionName ++ ".env ? " ++
"((" ++ castToFnWithEnv ++ ")" ++ functionName ++ ".callback)(" ++ functionName ++ ".env" ++ (if null args then "" else ", ") ++ joinWithComma args ++ ")" ++
" : " ++
"((" ++ castToFn ++ ")" ++ functionName ++ ".callback)(" ++ joinWithComma args ++ ")"
in functionName ++ ".env ? "
++ "(("
++ castToFnWithEnv
++ ")"
++ functionName
++ ".callback)("
++ functionName
++ ".env"
++ (if null args then "" else ", ")
++ joinWithComma args
++ ")"
++ " : "
++ "(("
++ castToFn
++ ")"
++ functionName
++ ".callback)("
++ joinWithComma args
++ ")"
-- | Must cast a lambda:s .callback member to the correct type to be able to call it.
tyToCast :: Ty -> String
tyToCast t =
let FuncTy argTys retTy _ = t
in "§(Fn [" ++ joinWithSpace (map show argTys) ++ "] " ++ show retTy ++ ")" -- Note! The '§' means that the emitted type will be "raw" and not converted to 'Lambda'.
in "§(Fn [" ++ joinWithSpace (map show argTys) ++ "] " ++ show retTy ++ ")" -- Note! The '§' means that the emitted type will be "raw" and not converted to 'Lambda'.
----------------------------------------------------------------------------------------------------------
-- ACTUAL TEMPLATES
-- | This function accepts a pointer and will do nothing with it.
templateNoop :: (String, Binder)
templateNoop = defineTemplate
(SymPath [] "noop")
(FuncTy [PointerTy (VarTy "a")] UnitTy StaticLifetimeTy)
"accepts a pointer and will do nothing with it."
(toTemplate "void $NAME ($a* a)")
(toTemplate "$DECL { }")
(const [])
templateNoop =
defineTemplate
(SymPath [] "noop")
(FuncTy [PointerTy (VarTy "a")] UnitTy StaticLifetimeTy)
"accepts a pointer and will do nothing with it."
(toTemplate "void $NAME ($a* a)")
(toTemplate "$DECL { }")
(const [])

111
src/ToTemplate.hs
View File

@ -1,78 +1,81 @@
module ToTemplate where
import qualified Text.Parsec as Parsec
import Text.Parsec ((<|>))
import Obj
import Parsing
import qualified Text.Parsec as Parsec
import Text.Parsec ((<|>))
import Util
-- | High-level helper function for creating templates from strings of C code.
toTemplate :: String -> [Token]
toTemplate text = case Parsec.runParser templateSyntax 0 "(template)" text of
Right ok -> ok
Left err -> error (show err)
Right ok -> ok
Left err -> error (show err)
where
templateSyntax :: Parsec.Parsec String Int [Token]
templateSyntax = Parsec.many parseTok
parseTok = Parsec.try parseTokDecl <|> --- $DECL
Parsec.try parseTokName <|> --- $NAME
Parsec.try parseTokTyGrouped <|> --- i.e. $(Fn [Int] t)
Parsec.try parseTokTyRawGrouped <|>
Parsec.try parseTokTy <|> --- i.e. $t
parseTokC --- Anything else...
parseTok =
Parsec.try parseTokDecl
<|> Parsec.try parseTokName --- $DECL
<|> Parsec.try parseTokTyGrouped --- $NAME
<|> Parsec.try parseTokTyRawGrouped --- i.e. $(Fn [Int] t)
<|> Parsec.try parseTokTy
<|> parseTokC --- i.e. $t
--- Anything else...
parseTokDecl :: Parsec.Parsec String Int Token
parseTokDecl = do _ <- Parsec.string "$DECL"
pure TokDecl
parseTokDecl = do
_ <- Parsec.string "$DECL"
pure TokDecl
parseTokName :: Parsec.Parsec String Int Token
parseTokName = do _ <- Parsec.string "$NAME"
pure TokName
parseTokName = do
_ <- Parsec.string "$NAME"
pure TokName
parseTokC :: Parsec.Parsec String Int Token
parseTokC = do s <- Parsec.many1 validInSymbol
pure (TokC s)
where validInSymbol = Parsec.choice [Parsec.letter, Parsec.digit, Parsec.oneOf validCharactersInTemplate]
validCharactersInTemplate = " ><{}()[]|;:.,_-+*#/'^!?€%&=@\"\n\t\\"
parseTokC = do
s <- Parsec.many1 validInSymbol
pure (TokC s)
where
validInSymbol = Parsec.choice [Parsec.letter, Parsec.digit, Parsec.oneOf validCharactersInTemplate]
validCharactersInTemplate = " ><{}()[]|;:.,_-+*#/'^!?€%&=@\"\n\t\\"
parseTokTy :: Parsec.Parsec String Int Token
parseTokTy = do _ <- Parsec.char '$'
s <- Parsec.many1 Parsec.letter
pure (toTokTy Normal s)
parseTokTy = do
_ <- Parsec.char '$'
s <- Parsec.many1 Parsec.letter
pure (toTokTy Normal s)
parseTokTyGrouped :: Parsec.Parsec String Int Token
parseTokTyGrouped = do _ <- Parsec.char '$'
toTokTy Normal <$> parseGrouping
parseTokTyGrouped = do
_ <- Parsec.char '$'
toTokTy Normal <$> parseGrouping
parseTokTyRawGrouped :: Parsec.Parsec String Int Token
parseTokTyRawGrouped = do _ <- Parsec.char '§'
toTokTy Raw <$> parseGrouping
parseTokTyRawGrouped = do
_ <- Parsec.char '§'
toTokTy Raw <$> parseGrouping
parseGrouping :: Parsec.Parsec String Int String
parseGrouping = do _ <- Parsec.char '('
Parsec.putState 1 -- One paren to close.
fmap ('(' :) (Parsec.many parseCharBalanced)
-- Note: The closing paren is read by parseCharBalanced.
parseGrouping = do
_ <- Parsec.char '('
Parsec.putState 1 -- One paren to close.
fmap ('(' :) (Parsec.many parseCharBalanced)
-- Note: The closing paren is read by parseCharBalanced.
parseCharBalanced :: Parsec.Parsec String Int Char
parseCharBalanced = do balanceState <- Parsec.getState
if balanceState > 0
then Parsec.try openParen <|>
Parsec.try closeParen <|>
Parsec.anyChar
else Parsec.char '\0' -- Should always fail which will end the string.
parseCharBalanced = do
balanceState <- Parsec.getState
if balanceState > 0
then
Parsec.try openParen
<|> Parsec.try closeParen
<|> Parsec.anyChar
else Parsec.char '\0' -- Should always fail which will end the string.
openParen :: Parsec.Parsec String Int Char
openParen = do _ <- Parsec.char '('
Parsec.modifyState (+1)
pure '('
openParen = do
_ <- Parsec.char '('
Parsec.modifyState (+ 1)
pure '('
closeParen :: Parsec.Parsec String Int Char
closeParen = do _ <- Parsec.char ')'
Parsec.modifyState (\x -> x - 1)
pure ')'
closeParen = do
_ <- Parsec.char ')'
Parsec.modifyState (\x -> x - 1)
pure ')'
-- | Converts a string containing a type to a template token ('TokTy').
-- | i.e. the string "(Array Int)" becomes (TokTy (StructTy "Array" IntTy)).
@ -82,6 +85,6 @@ toTokTy mode s =
Left err -> error (show err)
Right [] -> error ("toTokTy got [] when parsing: '" ++ s ++ "'")
Right [xobj] -> case xobjToTy xobj of
Just ok -> TokTy ok mode
Nothing -> error ("toTokTy failed to convert this s-expression to a type: " ++ pretty xobj)
Just ok -> TokTy ok mode
Nothing -> error ("toTokTy failed to convert this s-expression to a type: " ++ pretty xobj)
Right xobjs -> error ("toTokTy parsed too many s-expressions: " ++ joinWithSpace (map pretty xobjs))

517
src/TypeError.hs
View File

@ -1,251 +1,312 @@
module TypeError where
import Constraints
import Data.Maybe (fromMaybe)
import Types
import Info
import Lookup
import Obj
import Project
import Constraints
import Types
import Util
import Lookup
import Info
data TypeError = SymbolMissingType XObj Env
| DefnMissingType XObj
| DefMissingType XObj
| ExpressionMissingType XObj
| SymbolNotDefined SymPath XObj Env
| InvalidObj Obj XObj
| CantUseDerefOutsideFunctionApplication XObj
| NotAType XObj
| WrongArgCount XObj Int Int
| NotAFunction XObj
| NoStatementsInDo XObj
| TooManyFormsInBody XObj
| NoFormsInBody XObj
| LeadingColon XObj
| UnificationFailed Constraint TypeMappings [Constraint]
| CantDisambiguate XObj String Ty [(Ty, SymPath)]
| CantDisambiguateInterfaceLookup XObj String Ty [(Ty, SymPath)]
| SeveralExactMatches XObj String Ty [(Ty, SymPath)]
| NoMatchingSignature XObj String Ty [(Ty, SymPath)]
| HolesFound [(String, Ty)]
| FailedToExpand XObj EvalError
| NotAValidType XObj
| FunctionsCantReturnRefTy XObj Ty
| LetCantReturnRefTy XObj Ty
| GettingReferenceToUnownedValue XObj
| UsingUnownedValue XObj
| UsingCapturedValue XObj
| ArraysCannotContainRefs XObj
| MainCanOnlyReturnUnitOrInt XObj Ty
| MainCannotHaveArguments XObj Int
| CannotConcretize XObj
| TooManyAnnotateCalls XObj
| CannotSet XObj
| CannotSetVariableFromLambda XObj XObj
| DoesNotMatchSignatureAnnotation XObj Ty -- Not used at the moment (but should?)
| CannotMatch XObj
| InvalidSumtypeCase XObj
| InvalidMemberType Ty XObj
| InvalidMemberTypeWhenConcretizing Ty XObj TypeError
| NotAmongRegisteredTypes Ty XObj
| UnevenMembers [XObj]
| DuplicatedMembers [XObj]
| InvalidLetBinding [XObj] (XObj, XObj)
| DuplicateBinding XObj
| DefinitionsMustBeAtToplevel XObj
| UsingDeadReference XObj String
| UninhabitedConstructor Ty XObj Int Int
data TypeError
= SymbolMissingType XObj Env
| DefnMissingType XObj
| DefMissingType XObj
| ExpressionMissingType XObj
| SymbolNotDefined SymPath XObj Env
| InvalidObj Obj XObj
| CantUseDerefOutsideFunctionApplication XObj
| NotAType XObj
| WrongArgCount XObj Int Int
| NotAFunction XObj
| NoStatementsInDo XObj
| TooManyFormsInBody XObj
| NoFormsInBody XObj
| LeadingColon XObj
| UnificationFailed Constraint TypeMappings [Constraint]
| CantDisambiguate XObj String Ty [(Ty, SymPath)]
| CantDisambiguateInterfaceLookup XObj String Ty [(Ty, SymPath)]
| SeveralExactMatches XObj String Ty [(Ty, SymPath)]
| NoMatchingSignature XObj String Ty [(Ty, SymPath)]
| HolesFound [(String, Ty)]
| FailedToExpand XObj EvalError
| NotAValidType XObj
| FunctionsCantReturnRefTy XObj Ty
| LetCantReturnRefTy XObj Ty
| GettingReferenceToUnownedValue XObj
| UsingUnownedValue XObj
| UsingCapturedValue XObj
| ArraysCannotContainRefs XObj
| MainCanOnlyReturnUnitOrInt XObj Ty
| MainCannotHaveArguments XObj Int
| CannotConcretize XObj
| TooManyAnnotateCalls XObj
| CannotSet XObj
| CannotSetVariableFromLambda XObj XObj
| DoesNotMatchSignatureAnnotation XObj Ty -- Not used at the moment (but should?)
| CannotMatch XObj
| InvalidSumtypeCase XObj
| InvalidMemberType Ty XObj
| InvalidMemberTypeWhenConcretizing Ty XObj TypeError
| NotAmongRegisteredTypes Ty XObj
| UnevenMembers [XObj]
| DuplicatedMembers [XObj]
| InvalidLetBinding [XObj] (XObj, XObj)
| DuplicateBinding XObj
| DefinitionsMustBeAtToplevel XObj
| UsingDeadReference XObj String
| UninhabitedConstructor Ty XObj Int Int
instance Show TypeError where
show (SymbolMissingType xobj env) =
"I couldn’t find a type for the symbol '" ++ getName xobj ++ "' at " ++
prettyInfoFromXObj xobj ++ " in the environment:\n" ++
prettyEnvironment env ++
"\n\nIt might be too general. You could try adding a type hint using `the`."
"I couldn’t find a type for the symbol '" ++ getName xobj ++ "' at "
++ prettyInfoFromXObj xobj
++ " in the environment:\n"
++ prettyEnvironment env
++ "\n\nIt might be too general. You could try adding a type hint using `the`."
show (DefnMissingType xobj) =
"I couldn’t find a type for the function definition '" ++ getName xobj ++
"' at " ++ prettyInfoFromXObj xobj ++
".\n\nIt might be too general. You could try adding a type hint using `the`."
"I couldn’t find a type for the function definition '" ++ getName xobj
++ "' at "
++ prettyInfoFromXObj xobj
++ ".\n\nIt might be too general. You could try adding a type hint using `the`."
show (DefMissingType xobj) =
"I couldn’t find a type for the variable definition '" ++ getName xobj ++
"' at " ++ prettyInfoFromXObj xobj ++
".\n\nIt might be too general. You could try adding a type hint using `the`."
show (ExpressionMissingType xobj)=
"I couldn’t find a type for the expression '" ++ pretty xobj ++ "' at " ++
prettyInfoFromXObj xobj ++
".\n\nIt might be too general. You could try adding a type hint using `the`."
"I couldn’t find a type for the variable definition '" ++ getName xobj
++ "' at "
++ prettyInfoFromXObj xobj
++ ".\n\nIt might be too general. You could try adding a type hint using `the`."
show (ExpressionMissingType xobj) =
"I couldn’t find a type for the expression '" ++ pretty xobj ++ "' at "
++ prettyInfoFromXObj xobj
++ ".\n\nIt might be too general. You could try adding a type hint using `the`."
show (SymbolNotDefined symPath@(SymPath p _) xobj env) =
"I couldn’t find the symbol '" ++ show symPath ++ "' at " ++
prettyInfoFromXObj xobj ++ ".\n\n" ++
matches (keysInEnvEditDistance symPath env 3)
where matches [] = "Maybe you forgot to define it?"
matches x = "Maybe you wanted one of the following?\n " ++ joinWith "\n " (map (show . SymPath p) x)
"I couldn’t find the symbol '" ++ show symPath ++ "' at "
++ prettyInfoFromXObj xobj
++ ".\n\n"
++ matches (keysInEnvEditDistance symPath env 3)
where
matches [] = "Maybe you forgot to define it?"
matches x = "Maybe you wanted one of the following?\n " ++ joinWith "\n " (map (show . SymPath p) x)
show (InvalidObj (Defn _) xobj) =
"I didn’t understand the function definition at " ++
prettyInfoFromXObj xobj ++
".\n\nIs it valid? Every `defn` needs to follow the form `(defn name [arg] body)`."
"I didn’t understand the function definition at "
++ prettyInfoFromXObj xobj
++ ".\n\nIs it valid? Every `defn` needs to follow the form `(defn name [arg] body)`."
show (CantUseDerefOutsideFunctionApplication xobj) =
"I found a `deref` / `~` that isn’t inside a function application at " ++
prettyInfoFromXObj xobj ++
".\n\nEvery usage of `~` must be inside a function application."
"I found a `deref` / `~` that isn’t inside a function application at "
++ prettyInfoFromXObj xobj
++ ".\n\nEvery usage of `~` must be inside a function application."
show (InvalidObj If xobj) =
"I didn’t understand the `if` statement at " ++ prettyInfoFromXObj xobj ++
".\n\nIs it valid? Every `if` needs to follow the form `(if cond iftrue iffalse)`."
"I didn’t understand the `if` statement at " ++ prettyInfoFromXObj xobj
++ ".\n\nIs it valid? Every `if` needs to follow the form `(if cond iftrue iffalse)`."
show (InvalidObj o xobj) =
"I didn’t understand the form `" ++ show o ++ "` at " ++
prettyInfoFromXObj xobj ++ ".\n\nIs it valid?"
"I didn’t understand the form `" ++ show o ++ "` at "
++ prettyInfoFromXObj xobj
++ ".\n\nIs it valid?"
show (WrongArgCount xobj expected actual) =
"You used the wrong number of arguments in '" ++ getName xobj ++ "' at " ++
prettyInfoFromXObj xobj ++ ". I expected " ++ show expected ++
", but got " ++ show actual ++ "."
"You used the wrong number of arguments in '" ++ getName xobj ++ "' at "
++ prettyInfoFromXObj xobj
++ ". I expected "
++ show expected
++ ", but got "
++ show actual
++ "."
show (NotAFunction xobj) =
"You are trying to call the non-function `" ++ getName xobj ++ "` at " ++
prettyInfoFromXObj xobj ++ "."
"You are trying to call the non-function `" ++ getName xobj ++ "` at "
++ prettyInfoFromXObj xobj
++ "."
show (NoStatementsInDo xobj) =
"There are no expressions inside of the `do` statement at " ++
prettyInfoFromXObj xobj ++
".\n\nAll instances of `do` need to have one or more expressions in it."
"There are no expressions inside of the `do` statement at "
++ prettyInfoFromXObj xobj
++ ".\n\nAll instances of `do` need to have one or more expressions in it."
show (TooManyFormsInBody xobj) =
"There are too many expressions in the body of the form at " ++
prettyInfoFromXObj xobj ++ ".\n\nTry wrapping them in a `do`."
"There are too many expressions in the body of the form at "
++ prettyInfoFromXObj xobj
++ ".\n\nTry wrapping them in a `do`."
show (NoFormsInBody xobj) =
"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`."
"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 a b aObj bObj ctx _) mappings _) =
"I can’t match the types `" ++ show (recursiveLookupTy mappings a) ++
"` and `" ++ show (recursiveLookupTy mappings b) ++ "`" ++ extra ++
".\n\n" ++
--show aObj ++ "\nWITH\n" ++ show bObj ++ "\n\n" ++
" " ++ pretty aObj ++ " : " ++ showTypeFromXObj mappings aObj ++
"\n At " ++ prettyInfoFromXObj aObj ++ "" ++
"\n\n" ++
" " ++ pretty bObj ++ " : " ++ showTypeFromXObj mappings bObj ++
"\n At " ++ prettyInfoFromXObj bObj ++ "\n"
-- ++ "Constraint: " ++ show constraint ++ "\n\n"
-- "All constraints:\n" ++ show constraints ++ "\n\n" ++
-- "Mappings: \n" ++ show mappings ++ "\n\n"
where extra = if ctx == aObj || ctx == bObj then "" else " within `" ++ snip (pretty ctx) ++ "`"
snip s = if length s > 25
then take 15 s ++ " ... " ++ drop (length s - 5) s
else s
"I can’t match the types `" ++ show (recursiveLookupTy mappings a)
++ "` and `"
++ show (recursiveLookupTy mappings b)
++ "`"
++ extra
++ ".\n\n"
++
--show aObj ++ "\nWITH\n" ++ show bObj ++ "\n\n" ++
" "
++ pretty aObj
++ " : "
++ showTypeFromXObj mappings aObj
++ "\n At "
++ prettyInfoFromXObj aObj
++ ""
++ "\n\n"
++ " "
++ pretty bObj
++ " : "
++ showTypeFromXObj mappings bObj
++ "\n At "
++ prettyInfoFromXObj bObj
++ "\n"
where
-- ++ "Constraint: " ++ show constraint ++ "\n\n"
-- "All constraints:\n" ++ show constraints ++ "\n\n" ++
-- "Mappings: \n" ++ show mappings ++ "\n\n"
extra = if ctx == aObj || ctx == bObj then "" else " within `" ++ snip (pretty ctx) ++ "`"
snip s =
if length s > 25
then take 15 s ++ " ... " ++ drop (length s - 5) s
else s
show (CantDisambiguate xobj originalName theType options) =
"I found an ambiguous symbol `" ++ originalName ++ "` of type `" ++
show theType ++ "` at " ++ prettyInfoFromXObj xobj ++
"\nPossibilities:\n " ++
joinWith "\n " (map (\(t, p) -> show p ++ " : " ++ show t) options)
"I found an ambiguous symbol `" ++ originalName ++ "` of type `"
++ show theType
++ "` at "
++ prettyInfoFromXObj xobj
++ "\nPossibilities:\n "
++ joinWith "\n " (map (\(t, p) -> show p ++ " : " ++ show t) options)
show (CantDisambiguateInterfaceLookup xobj name theType options) =
"I found an ambiguous interface `" ++ name ++ "` of type `" ++
show theType ++ "` at " ++ prettyInfoFromXObj xobj ++
"\nPossibilities:\n " ++
joinWith "\n " (map (\(t, p) -> show p ++ " : " ++ show t) options)
"I found an ambiguous interface `" ++ name ++ "` of type `"
++ show theType
++ "` at "
++ prettyInfoFromXObj xobj
++ "\nPossibilities:\n "
++ joinWith "\n " (map (\(t, p) -> show p ++ " : " ++ show t) options)
show (SeveralExactMatches xobj name theType options) =
"There are several exact matches for the interface `" ++ name ++
"` of type `" ++ show theType ++ "` at " ++ prettyInfoFromXObj xobj ++
"\nPossibilities:\n " ++
joinWith "\n " (map (\(t, p) -> show p ++ " : " ++ show t) options)
"There are several exact matches for the interface `" ++ name
++ "` of type `"
++ show theType
++ "` at "
++ prettyInfoFromXObj xobj
++ "\nPossibilities:\n "
++ joinWith "\n " (map (\(t, p) -> show p ++ " : " ++ show t) options)
show (NoMatchingSignature xobj originalName theType options) =
"I can’t find any implementation for the interface `" ++ originalName ++
"` of type " ++ show theType ++ " at " ++ prettyInfoFromXObj xobj ++
".\n\nNone of the possibilities have the correct signature:\n " ++ joinWith
"\n " (map (\(t, p) -> show p ++ " : " ++ show t) options)
"I can’t find any implementation for the interface `" ++ originalName
++ "` of type "
++ show theType
++ " at "
++ prettyInfoFromXObj xobj
++ ".\n\nNone of the possibilities have the correct signature:\n "
++ joinWith
"\n "
(map (\(t, p) -> show p ++ " : " ++ show t) options)
show (LeadingColon xobj) =
"I found a symbol '" ++ pretty xobj ++ "' that starts with a colon at " ++
prettyInfoFromXObj xobj ++ ".\n\nThis is disallowed."
"I found a symbol '" ++ pretty xobj ++ "' that starts with a colon at "
++ prettyInfoFromXObj xobj
++ ".\n\nThis is disallowed."
show (HolesFound holes) =
"I found the following holes:\n\n " ++
joinWith "\n " (map (\(name, t) -> name ++ " : " ++ show t) holes) ++
"\n"
"I found the following holes:\n\n "
++ joinWith "\n " (map (\(name, t) -> name ++ " : " ++ show t) holes)
++ "\n"
show (FailedToExpand xobj err@(EvalError _ hist _ _)) =
"I failed to expand a macro at " ++ prettyInfoFromXObj xobj ++
".\n\nThe error message I got was: " ++ show err ++
"\nTraceback:\n" ++
unlines (map (prettyUpTo 60) hist)
"I failed to expand a macro at " ++ prettyInfoFromXObj xobj
++ ".\n\nThe error message I got was: "
++ show err
++ "\nTraceback:\n"
++ unlines (map (prettyUpTo 60) hist)
show (NotAValidType xobj) =
pretty xobj ++ "is not a valid type at " ++ prettyInfoFromXObj xobj
show (FunctionsCantReturnRefTy xobj t) =
"Functions can’t return references. " ++ getName xobj ++ " : " ++ show t
++ " at " ++ prettyInfoFromXObj xobj ++
"\n\nYou’ll have to copy the return value using `@`."
++ " at "
++ prettyInfoFromXObj xobj
++ "\n\nYou’ll have to copy the return value using `@`."
show (LetCantReturnRefTy xobj t) =
"`let` expressions can’t return references. " ++ pretty xobj ++ " : " ++
show t ++ " at " ++ prettyInfoFromXObj xobj ++
"\n\nYou’ll have to copy the return value using `@`."
"`let` expressions can’t return references. " ++ pretty xobj ++ " : "
++ show t
++ " at "
++ prettyInfoFromXObj xobj
++ "\n\nYou’ll have to copy the return value using `@`."
show (GettingReferenceToUnownedValue xobj) =
"You’re referencing a given-away value `" ++ pretty xobj ++ "` at " ++ --"' (expression " ++ freshVar i ++ ") at " ++
prettyInfoFromXObj xobj ++ "\n" ++ show xobj ++
"\n\nYou’ll have to copy the value using `@`."
"You’re referencing a given-away value `" ++ pretty xobj ++ "` at "
++ prettyInfoFromXObj xobj --"' (expression " ++ freshVar i ++ ") at " ++
++ "\n"
++ show xobj
++ "\n\nYou’ll have to copy the value using `@`."
show (UsingUnownedValue xobj) =
"You’re using a given-away value `" ++ pretty xobj ++ "` at " ++
prettyInfoFromXObj xobj ++ ".\n\nYou’ll have to copy the value using `@`."
"You’re using a given-away value `" ++ pretty xobj ++ "` at "
++ prettyInfoFromXObj xobj
++ ".\n\nYou’ll have to copy the value using `@`."
show (UsingCapturedValue xobj) =
"You’re using a value `" ++ pretty xobj ++
"` that was captured by a function at " ++ prettyInfoFromXObj xobj ++ "."
"You’re using a value `" ++ pretty xobj
++ "` that was captured by a function at "
++ prettyInfoFromXObj xobj
++ "."
show (ArraysCannotContainRefs xobj) =
"Arrays can’t contain references: `" ++ pretty xobj ++ "` at " ++
prettyInfoFromXObj xobj ++ ".\n\nYou’ll have to make a copy using `@`."
"Arrays can’t contain references: `" ++ pretty xobj ++ "` at "
++ prettyInfoFromXObj xobj
++ ".\n\nYou’ll have to make a copy using `@`."
show (MainCanOnlyReturnUnitOrInt _ t) =
"The main function can only return an `Int` or a unit type (`()`), but it got `" ++
show t ++ "`."
"The main function can only return an `Int` or a unit type (`()`), but it got `"
++ show t
++ "`."
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 " ++
prettyInfoFromXObj xobj ++
".\n\nIt might be too general. You could try adding a type hint using `the`."
"I’m unable to concretize the expression '" ++ pretty xobj ++ "' at "
++ prettyInfoFromXObj xobj
++ ".\n\nIt might be too general. You could try adding a type hint using `the`."
show (TooManyAnnotateCalls xobj) =
"There were too many annotation calls when annotating `" ++ pretty xobj ++
"` at " ++ prettyInfoFromXObj xobj ++
".\n\n I deduced it was an infinite loop."
"There were too many annotation calls when annotating `" ++ pretty xobj
++ "` at "
++ prettyInfoFromXObj xobj
++ ".\n\n I deduced it was an infinite loop."
show (NotAType xobj) =
"I don’t understand the type '" ++ pretty xobj ++ "' at " ++
prettyInfoFromXObj xobj ++ "\n\nIs it defined?"
"I don’t understand the type '" ++ pretty xobj ++ "' at "
++ prettyInfoFromXObj xobj
++ "\n\nIs it defined?"
show (CannotSet xobj) =
"I can’t `set!` the expression `" ++ pretty xobj ++ "` at " ++
prettyInfoFromXObj xobj ++ ".\n\nOnly variables can be reset using `set!`."
"I can’t `set!` the expression `" ++ pretty xobj ++ "` at "
++ prettyInfoFromXObj xobj
++ ".\n\nOnly variables can be reset using `set!`."
show (CannotSetVariableFromLambda variable _) =
"I can’t `set!` the variable `" ++ pretty variable ++ "` at " ++
prettyInfoFromXObj variable ++ " because it's defined outside the lambda."
"I can’t `set!` the variable `" ++ pretty variable ++ "` at "
++ prettyInfoFromXObj variable
++ " because it's defined outside the lambda."
show (DoesNotMatchSignatureAnnotation xobj sigTy) =
"The definition at " ++ prettyInfoFromXObj xobj ++
" does not match its annotation provided to `sig` as `" ++ show sigTy ++
"`, its actual type is `" ++ show (forceTy xobj) ++ "`."
"The definition at " ++ prettyInfoFromXObj xobj
++ " does not match its annotation provided to `sig` as `"
++ show sigTy
++ "`, its actual type is `"
++ show (forceTy xobj)
++ "`."
show (CannotMatch xobj) =
"I can’t `match` `" ++ pretty xobj ++ "` at " ++ prettyInfoFromXObj xobj ++
".\n\nOnly sumtypes can be matched against."
"I can’t `match` `" ++ pretty xobj ++ "` at " ++ prettyInfoFromXObj xobj
++ ".\n\nOnly sumtypes can be matched against."
show (InvalidSumtypeCase xobj) =
"I failed to read `" ++ pretty xobj ++ "` as a sumtype case at " ++
prettyInfoFromXObj xobj ++
".\n\nSumtype cases look like this: `(Foo [Int typevar])`"
"I failed to read `" ++ pretty xobj ++ "` as a sumtype case at "
++ prettyInfoFromXObj xobj
++ ".\n\nSumtype cases look like this: `(Foo [Int typevar])`"
show (InvalidMemberType t xobj) =
"I can’t use the type `" ++ show t ++ "` as a member type at " ++
prettyInfoFromXObj xobj ++
".\n\nIs it defined and captured in the head of the type definition?"
"I can’t use the type `" ++ show t ++ "` as a member type at "
++ prettyInfoFromXObj xobj
++ ".\n\nIs it defined and captured in the head of the type definition?"
show (InvalidMemberTypeWhenConcretizing t xobj err) =
"I can’t use the concrete type `" ++ show t ++ "` at " ++ prettyInfoFromXObj xobj ++ ": " ++ show err
show (NotAmongRegisteredTypes t xobj) =
"I can’t find a definition for the type `" ++ show t ++ "` at " ++
prettyInfoFromXObj xobj ++ ".\n\nWas it registered?"
"I can’t find a definition for the type `" ++ show t ++ "` at "
++ prettyInfoFromXObj xobj
++ ".\n\nWas it registered?"
show (UnevenMembers xobjs) =
"The number of members and types is uneven: `" ++
joinWithComma (map pretty xobjs) ++ "` at " ++
prettyInfoFromXObj (head xobjs) ++
".\n\nBecause they are pairs of names and their types, they need to be even.\nDid you forget a name or type?"
"The number of members and types is uneven: `"
++ joinWithComma (map pretty xobjs)
++ "` at "
++ prettyInfoFromXObj (head xobjs)
++ ".\n\nBecause they are pairs of names and their types, they need to be even.\nDid you forget a name or type?"
show (DuplicatedMembers xobjs) =
"Duplicate members: `" ++
joinWithComma (map pretty xobjs) ++ "` at " ++
prettyInfoFromXObj (head xobjs)
"Duplicate members: `"
++ joinWithComma (map pretty xobjs)
++ "` at "
++ prettyInfoFromXObj (head xobjs)
show (InvalidLetBinding xobjs (sym, expr)) =
"The binding `[" ++ pretty sym ++ " " ++ pretty expr ++ "]` is invalid at " ++
prettyInfoFromXObj (head xobjs) ++ ". \n\n Binding names must be symbols."
"The binding `[" ++ pretty sym ++ " " ++ pretty expr ++ "]` is invalid at "
++ prettyInfoFromXObj (head xobjs)
++ ". \n\n Binding names must be symbols."
show (DuplicateBinding xobj) =
"I encountered a duplicate binding `" ++ pretty xobj ++ "` inside the `let` at " ++ prettyInfoFromXObj xobj ++ "."
show (DefinitionsMustBeAtToplevel xobj) =
"I encountered a definition that was not at top level: `" ++ pretty xobj ++ "`"
show (UsingDeadReference xobj dependsOn) =
"The reference '" ++ pretty xobj ++ "' (depending on the variable '" ++ dependsOn ++ "') isn't alive at " ++ prettyInfoFromXObj xobj ++ "."
show (UninhabitedConstructor ty xobj got wanted) =
@ -255,9 +316,9 @@ machineReadableErrorStrings :: FilePathPrintLength -> TypeError -> [String]
machineReadableErrorStrings fppl err =
case err of
(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) ++ "."]
[ 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) ++ "."
]
(DefnMissingType xobj) ->
[machineReadableInfoFromXObj fppl xobj ++ " Function definition '" ++ getName xobj ++ "' missing type."]
(DefMissingType xobj) ->
@ -286,35 +347,37 @@ machineReadableErrorStrings fppl err =
[machineReadableInfoFromXObj fppl xobj ++ " Too many expressions in body position."]
(NoFormsInBody xobj) ->
[machineReadableInfoFromXObj fppl xobj ++ " No expressions in body position."]
(CantDisambiguate xobj originalName theType options) ->
[machineReadableInfoFromXObj fppl xobj ++ " Can't disambiguate symbol '" ++ originalName ++ "' of type " ++ show theType ++
"\nPossibilities:\n " ++ joinWith "\n " (map (\(t, p) -> show p ++ " : " ++ show t) options)]
[ machineReadableInfoFromXObj fppl xobj ++ " Can't disambiguate symbol '" ++ originalName ++ "' of type " ++ show theType
++ "\nPossibilities:\n "
++ joinWith "\n " (map (\(t, p) -> show p ++ " : " ++ show t) options)
]
(CantDisambiguateInterfaceLookup xobj name theType options) ->
[machineReadableInfoFromXObj fppl xobj ++ " Can't disambiguate interface lookup symbol '" ++ name ++ "' of type " ++ show theType ++
"\nPossibilities:\n " ++ joinWith "\n " (map (\(t, p) -> show p ++ " : " ++ show t) options)]
[ machineReadableInfoFromXObj fppl xobj ++ " Can't disambiguate interface lookup symbol '" ++ name ++ "' of type " ++ show theType
++ "\nPossibilities:\n "
++ joinWith "\n " (map (\(t, p) -> show p ++ " : " ++ show t) options)
]
(SeveralExactMatches xobj name theType options) ->
[machineReadableInfoFromXObj fppl xobj ++ " Several exact matches for interface lookup symbol '" ++ name ++ "' of type " ++ show theType ++ "\nPossibilities:\n " ++ joinWith "\n " (map (\(t, p) -> show p ++ " : " ++ show t) options)]
(NoMatchingSignature xobj originalName theType options) ->
[machineReadableInfoFromXObj fppl xobj ++ " Can't find matching lookup for symbol '" ++ originalName ++ "' of type " ++ show theType ++
"\nNone of the possibilities have the correct signature:\n " ++ joinWith
"\n " (map (\(t, p) -> show p ++ " : " ++ show t) options)]
[ machineReadableInfoFromXObj fppl xobj ++ " Can't find matching lookup for symbol '" ++ originalName ++ "' of type " ++ show theType
++ "\nNone of the possibilities have the correct signature:\n "
++ joinWith
"\n "
(map (\(t, p) -> show p ++ " : " ++ show t) options)
]
(LeadingColon xobj) ->
[machineReadableInfoFromXObj fppl xobj ++ " Symbol '" ++ pretty xobj ++ "' starting with a colon (reserved for REPL shortcuts)."]
-- (HolesFound holes) ->
-- (map (\(name, t) -> machineReadableInfoFromXObj fppl xobj ++ " " ++ name ++ " : " ++ show t) holes)
(FailedToExpand xobj (EvalError errorMessage _ _ _)) ->
[machineReadableInfoFromXObj fppl xobj ++ "Failed to expand: " ++ errorMessage]
-- TODO: Remove overlapping errors:
(NotAValidType xobj) ->
[machineReadableInfoFromXObj fppl xobj ++ " Not a valid type: " ++ pretty xobj ++ "."]
(NotAType xobj) ->
[machineReadableInfoFromXObj fppl xobj ++ " Can't understand the type '" ++ pretty xobj ++ "'."]
(FunctionsCantReturnRefTy xobj t) ->
[machineReadableInfoFromXObj fppl xobj ++ " Functions can't return references. " ++ getName xobj ++ " : " ++ show t ++ "."]
(LetCantReturnRefTy xobj t) ->
@ -327,35 +390,27 @@ machineReadableErrorStrings fppl err =
[machineReadableInfoFromXObj fppl xobj ++ " Using a captured value '" ++ pretty xobj ++ "'."]
(ArraysCannotContainRefs xobj) ->
[machineReadableInfoFromXObj fppl xobj ++ " Arrays can't contain references: '" ++ pretty xobj ++ "'."]
(MainCanOnlyReturnUnitOrInt xobj t) ->
[machineReadableInfoFromXObj fppl xobj ++ " Main function can only return Int or (), got " ++ show t ++ "."]
(MainCannotHaveArguments xobj c) ->
[machineReadableInfoFromXObj fppl xobj ++ " Main function can not have arguments, got " ++ show c ++ "."]
(TooManyAnnotateCalls xobj) ->
[machineReadableInfoFromXObj fppl xobj ++ " Too many annotate calls (infinite loop) when annotating '" ++ pretty xobj ++ "'."]
-- (InvalidMemberType msg) ->
-- -- msg
-- (InvalidMemberType msg) ->
-- -- msg
(CannotSet xobj) ->
[machineReadableInfoFromXObj fppl xobj ++ " Can't set! '" ++ pretty xobj ++ "'."]
(CannotSetVariableFromLambda variable _) ->
[machineReadableInfoFromXObj fppl variable ++ " Can't set! '" ++ pretty variable ++ "' from inside of a lambda."]
(CannotConcretize xobj) ->
[machineReadableInfoFromXObj fppl xobj ++ " Unable to concretize '" ++ pretty xobj ++ "'."]
(DoesNotMatchSignatureAnnotation xobj sigTy) ->
[machineReadableInfoFromXObj fppl xobj ++ "Definition does not match 'sig' annotation " ++ show sigTy ++ ", actual type is " ++ show (forceTy xobj)]
(CannotMatch xobj) ->
[machineReadableInfoFromXObj fppl xobj ++ " Can't match '" ++ pretty xobj ++ "'."]
(InvalidSumtypeCase xobj) ->
[machineReadableInfoFromXObj fppl xobj ++ " Failed to convert '" ++ pretty xobj ++ "' to a sumtype case."]
(InvalidMemberType t xobj) ->
[machineReadableInfoFromXObj fppl xobj ++ " Can't use '" ++ show t ++ "' as a type for a member variable."]
(NotAmongRegisteredTypes t xobj) ->
@ -372,7 +427,6 @@ machineReadableErrorStrings fppl err =
[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]
_ ->
[show err]
@ -381,14 +435,16 @@ joinedMachineReadableErrorStrings fppl err = joinWith "\n\n" (machineReadableErr
recursiveLookupTy :: TypeMappings -> Ty -> Ty
recursiveLookupTy mappings t = case t of
(VarTy v) -> fromMaybe t (recursiveLookup mappings v)
(RefTy r lt) -> RefTy (recursiveLookupTy mappings r) (recursiveLookupTy mappings lt)
(PointerTy p) -> PointerTy (recursiveLookupTy mappings p)
(StructTy n innerTys) -> StructTy n (map (recursiveLookupTy mappings) innerTys)
(FuncTy argTys retTy ltTy) -> FuncTy (map (recursiveLookupTy mappings) argTys)
(recursiveLookupTy mappings retTy)
(recursiveLookupTy mappings ltTy)
_ -> t
(VarTy v) -> fromMaybe t (recursiveLookup mappings v)
(RefTy r lt) -> RefTy (recursiveLookupTy mappings r) (recursiveLookupTy mappings lt)
(PointerTy p) -> PointerTy (recursiveLookupTy mappings p)
(StructTy n innerTys) -> StructTy n (map (recursiveLookupTy mappings) innerTys)
(FuncTy argTys retTy ltTy) ->
FuncTy
(map (recursiveLookupTy mappings) argTys)
(recursiveLookupTy mappings retTy)
(recursiveLookupTy mappings ltTy)
_ -> t
showTypeFromXObj :: TypeMappings -> XObj -> String
showTypeFromXObj mappings xobj =
@ -404,12 +460,13 @@ makeEvalError :: Context -> Maybe TypeError.TypeError -> String -> Maybe Info ->
makeEvalError ctx err msg info =
let fppl = projectFilePathPrintLength (contextProj ctx)
history = contextHistory ctx
in case contextExecMode ctx of
Check -> let messageWhenChecking = case err of
Just okErr -> joinedMachineReadableErrorStrings fppl okErr
Nothing ->
case info of
Just okInfo -> machineReadableInfo fppl okInfo ++ " " ++ msg
Nothing -> msg
in (ctx, Left (EvalError messageWhenChecking [] fppl Nothing)) -- Passing no history to avoid appending it at the end in 'show' instance for EvalError
_ -> (ctx, Left (EvalError msg history fppl info))
in case contextExecMode ctx of
Check ->
let messageWhenChecking = case err of
Just okErr -> joinedMachineReadableErrorStrings fppl okErr
Nothing ->
case info of
Just okInfo -> machineReadableInfo fppl okInfo ++ " " ++ msg
Nothing -> msg
in (ctx, Left (EvalError messageWhenChecking [] fppl Nothing)) -- Passing no history to avoid appending it at the end in 'show' instance for EvalError
_ -> (ctx, Left (EvalError msg history fppl info))

288
src/Types.hs
View File

@ -1,89 +1,97 @@
module Types ( TypeMappings
, Ty(..)
, showMaybeTy
, isTypeGeneric
, unifySignatures
, replaceTyVars
, areUnifiable
, typesDeleterFunctionType
, typesCopyFunctionType
, isFullyGenericType
, doesTypeContainTyVarWithName
, replaceConflicted
, lambdaEnvTy
, typeEqIgnoreLifetimes
, checkKinds
-- SymPath imports
, SymPath (..)
, mangle
, pathToC
, consPath
, Kind
, tyToKind
, isUnit
) where
module Types
( TypeMappings,
Ty (..),
showMaybeTy,
isTypeGeneric,
unifySignatures,
replaceTyVars,
areUnifiable,
typesDeleterFunctionType,
typesCopyFunctionType,
isFullyGenericType,
doesTypeContainTyVarWithName,
replaceConflicted,
lambdaEnvTy,
typeEqIgnoreLifetimes,
checkKinds,
-- SymPath imports
SymPath (..),
mangle,
pathToC,
consPath,
Kind,
tyToKind,
isUnit,
)
where
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
import Util
import SymPath
import Util
--import Debug.Trace
-- | Carp types.
data Ty = IntTy
| LongTy
| ByteTy
| BoolTy
| FloatTy
| DoubleTy
| StringTy
| PatternTy
| CharTy
| FuncTy [Ty] Ty Ty -- In order of appearance: (1) Argument types, (2) Return type, (3) Lifetime
| VarTy String
| UnitTy
| ModuleTy
| PointerTy Ty
| RefTy Ty Ty -- second Ty is the lifetime
| StaticLifetimeTy
| StructTy Ty [Ty] -- the name (possibly a var) of the struct, and it's type parameters
| ConcreteNameTy String -- the name of a struct
| TypeTy -- the type of types
| MacroTy
| DynamicTy -- the type of dynamic functions (used in REPL and macros)
| InterfaceTy
| Universe -- the type of types of types (the type of TypeTy)
deriving (Eq, Ord)
data Ty
= IntTy
| LongTy
| ByteTy
| BoolTy
| FloatTy
| DoubleTy
| StringTy
| PatternTy
| CharTy
| FuncTy [Ty] Ty Ty -- In order of appearance: (1) Argument types, (2) Return type, (3) Lifetime
| VarTy String
| UnitTy
| ModuleTy
| PointerTy Ty
| RefTy Ty Ty -- second Ty is the lifetime
| StaticLifetimeTy
| StructTy Ty [Ty] -- the name (possibly a var) of the struct, and it's type parameters
| ConcreteNameTy String -- the name of a struct
| TypeTy -- the type of types
| MacroTy
| DynamicTy -- the type of dynamic functions (used in REPL and macros)
| InterfaceTy
| Universe -- the type of types of types (the type of TypeTy)
deriving (Eq, Ord)
-- | Kinds checking
-- Carp's system is simple enough that we do not need to describe kinds by their airty.
-- After confirming two tys have either base or higher kind
-- unification checks are sufficient to determine whether their arities are compatible.
data Kind = Base
| Higher
deriving (Eq, Ord, Show)
data Kind
= Base
| Higher
deriving (Eq, Ord, Show)
tyToKind :: Ty -> Kind
tyToKind (StructTy _ _) = Higher
tyToKind (FuncTy _ _ _) = Higher -- the type of functions, consider the (->) constructor in Haskell
tyToKind (PointerTy _) = Higher
tyToKind (RefTy _ _) = Higher -- Refs may also be treated as a data constructor
tyToKind _ = Base
tyToKind (PointerTy _) = Higher
tyToKind (RefTy _ _) = Higher -- Refs may also be treated as a data constructor
tyToKind _ = Base
-- Exactly like '==' for Ty, but ignore lifetime parameter
typeEqIgnoreLifetimes :: Ty -> Ty -> Bool
typeEqIgnoreLifetimes (RefTy a _) (RefTy b _) = a == b
typeEqIgnoreLifetimes (FuncTy argsA retA _) (FuncTy argsB retB _) =
all (== True) (zipWith typeEqIgnoreLifetimes argsA argsB) &&
typeEqIgnoreLifetimes retA retB
all (== True) (zipWith typeEqIgnoreLifetimes argsA argsB)
&& typeEqIgnoreLifetimes retA retB
typeEqIgnoreLifetimes (StructTy a tyVarsA) (StructTy b tyVarsB) =
a == b &&
all (== True) (zipWith typeEqIgnoreLifetimes tyVarsA tyVarsB)
a == b
&& all (== True) (zipWith typeEqIgnoreLifetimes tyVarsA tyVarsB)
typeEqIgnoreLifetimes a b = a == b
data SumTyCase = SumTyCase { caseName :: String
, caseMembers :: [(String, Ty)]
} deriving (Show, Ord, Eq)
data SumTyCase
= SumTyCase
{ caseName :: String,
caseMembers :: [(String, Ty)]
}
deriving (Show, Ord, Eq)
fnOrLambda :: String
fnOrLambda =
@ -92,27 +100,27 @@ fnOrLambda =
_ -> "Fn" -- "λ"
instance Show Ty where
show IntTy = "Int"
show FloatTy = "Float"
show DoubleTy = "Double"
show LongTy = "Long"
show ByteTy = "Byte"
show BoolTy = "Bool"
show StringTy = "String"
show PatternTy = "Pattern"
show CharTy = "Char"
show IntTy = "Int"
show FloatTy = "Float"
show DoubleTy = "Double"
show LongTy = "Long"
show ByteTy = "Byte"
show BoolTy = "Bool"
show StringTy = "String"
show PatternTy = "Pattern"
show CharTy = "Char"
show (FuncTy argTys retTy StaticLifetimeTy) = "(" ++ fnOrLambda ++ " [" ++ joinWithComma (map show argTys) ++ "] " ++ show retTy ++ ")"
show (FuncTy argTys retTy lt) = "(" ++ fnOrLambda ++ " [" ++ joinWithComma (map show argTys) ++ "] " ++ show retTy ++ " " ++ show lt ++ ")"
show (VarTy t) = t
show UnitTy = "()"
show ModuleTy = "Module"
show TypeTy = "Type"
show InterfaceTy = "Interface"
show (StructTy s []) = (show s)
show (VarTy t) = t
show UnitTy = "()"
show ModuleTy = "Module"
show TypeTy = "Type"
show InterfaceTy = "Interface"
show (StructTy s []) = (show s)
show (StructTy s typeArgs) = "(" ++ (show s) ++ " " ++ joinWithSpace (map show typeArgs) ++ ")"
show (ConcreteNameTy name) = name
show (PointerTy p) = "(Ptr " ++ show p ++ ")"
show (RefTy r lt) =
show (PointerTy p) = "(Ptr " ++ show p ++ ")"
show (RefTy r lt) =
-- case r of
-- PointerTy _ -> listView
-- StructTy _ _ -> listView
@ -120,13 +128,13 @@ instance Show Ty where
-- _ -> "&" ++ show r
-- where listView = "(Ref " ++ show r ++ ")"
"(Ref " ++ show r ++ " " ++ show lt ++ ")"
show StaticLifetimeTy = "StaticLifetime"
show MacroTy = "Macro"
show DynamicTy = "Dynamic"
show StaticLifetimeTy = "StaticLifetime"
show MacroTy = "Macro"
show DynamicTy = "Dynamic"
showMaybeTy :: Maybe Ty -> String
showMaybeTy (Just t) = show t
showMaybeTy Nothing = "(missing-type)"
showMaybeTy Nothing = "(missing-type)"
isTypeGeneric :: Ty -> Bool
isTypeGeneric (VarTy _) = True
@ -139,30 +147,34 @@ isTypeGeneric _ = False
doesTypeContainTyVarWithName :: String -> Ty -> Bool
doesTypeContainTyVarWithName name (VarTy n) = name == n
doesTypeContainTyVarWithName name (FuncTy argTys retTy lt) =
doesTypeContainTyVarWithName name lt ||
any (doesTypeContainTyVarWithName name) argTys ||
doesTypeContainTyVarWithName name retTy
doesTypeContainTyVarWithName name lt
|| any (doesTypeContainTyVarWithName name) argTys
|| doesTypeContainTyVarWithName name retTy
doesTypeContainTyVarWithName name (StructTy n tyArgs) = doesTypeContainTyVarWithName name n || any (doesTypeContainTyVarWithName name) tyArgs
doesTypeContainTyVarWithName name (PointerTy p) = doesTypeContainTyVarWithName name p
doesTypeContainTyVarWithName name (RefTy r lt) = doesTypeContainTyVarWithName name r ||
doesTypeContainTyVarWithName name lt
doesTypeContainTyVarWithName name (RefTy r lt) =
doesTypeContainTyVarWithName name r
|| doesTypeContainTyVarWithName name lt
doesTypeContainTyVarWithName _ _ = False
replaceConflicted :: String -> Ty -> Ty
replaceConflicted name (VarTy n) = if n == name
then (VarTy (n ++ "conflicted"))
else (VarTy n)
replaceConflicted name (VarTy n) =
if n == name
then (VarTy (n ++ "conflicted"))
else (VarTy n)
replaceConflicted name (FuncTy argTys retTy lt) =
FuncTy (map (replaceConflicted name) argTys)
(replaceConflicted name retTy)
(replaceConflicted name lt)
FuncTy
(map (replaceConflicted name) argTys)
(replaceConflicted name retTy)
(replaceConflicted name lt)
replaceConflicted name (StructTy n tyArgs) = StructTy (replaceConflicted name n) (map (replaceConflicted name) tyArgs)
replaceConflicted name (PointerTy p) = PointerTy (replaceConflicted name p)
replaceConflicted name (RefTy r lt) = RefTy (replaceConflicted name r)
(replaceConflicted name lt)
replaceConflicted name (RefTy r lt) =
RefTy
(replaceConflicted name r)
(replaceConflicted name lt)
replaceConflicted _ t = t
-- | Map type variable names to actual types, eg. t0 => Int, t1 => Float
type TypeMappings = Map.Map String Ty
@ -170,31 +182,28 @@ type TypeMappings = Map.Map String Ty
-- create mappings that translate from the type variables to concrete types, e.g. "t0" => Int, "t1" => Bool
unifySignatures :: Ty -> Ty -> TypeMappings
unifySignatures at ct = Map.fromList (unify at ct)
where unify :: Ty -> Ty -> [(String, Ty)]
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 _) 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 (StructTy _ _) _ = [] -- error ("Can't unify " ++ show a ++ " with " ++ show b)
unify (PointerTy a) (PointerTy b) = unify a 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 (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 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)
where
unify :: Ty -> Ty -> [(String, Ty)]
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 _) 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 (StructTy _ _) _ = [] -- error ("Can't unify " ++ show a ++ " with " ++ show b)
unify (PointerTy a) (PointerTy b) = unify a 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 (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 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)
-- | Checks if two types will unify
areUnifiable :: Ty -> Ty -> Bool
@ -203,8 +212,9 @@ areUnifiable (VarTy _) _ = True
areUnifiable _ (VarTy _) = True
areUnifiable (StructTy a aArgs) (StructTy b bArgs)
| length aArgs /= length bArgs = False
| areUnifiable a b = let argBools = zipWith areUnifiable aArgs bArgs
in all (== True) argBools
| areUnifiable a b =
let argBools = zipWith areUnifiable aArgs bArgs
in all (== True) argBools
| otherwise = False
areUnifiable (StructTy (VarTy _) aArgs) (FuncTy bArgs _ _)
| length aArgs /= length bArgs = False
@ -216,16 +226,18 @@ areUnifiable (StructTy _ _) _ = False
areUnifiable (PointerTy a) (PointerTy b) = areUnifiable a b
areUnifiable (PointerTy _) _ = False
areUnifiable (RefTy a ltA) (RefTy b ltB) = areUnifiable a b && areUnifiable ltA ltB
areUnifiable RefTy{} _ = False
areUnifiable RefTy {} _ = False
areUnifiable (FuncTy argTysA retTyA ltA) (FuncTy argTysB retTyB ltB)
| length argTysA /= length argTysB = False
| otherwise = let argBools = zipWith areUnifiable argTysA argTysB
retBool = areUnifiable retTyA retTyB
ltBool = areUnifiable ltA ltB
in all (== True) (ltBool : retBool : argBools)
areUnifiable FuncTy{} _ = False
areUnifiable a b | a == b = True
| otherwise = False
| otherwise =
let argBools = zipWith areUnifiable argTysA argTysB
retBool = areUnifiable retTyA retTyB
ltBool = areUnifiable ltA ltB
in all (== True) (ltBool : retBool : argBools)
areUnifiable FuncTy {} _ = False
areUnifiable a b
| a == b = True
| otherwise = False
-- Checks whether or not the kindedness of types match
-- Kinds are polymorphic constructors such as (f a)
@ -235,7 +247,7 @@ checkKinds :: Ty -> Ty -> Bool
checkKinds (FuncTy argTysA retTyA _) (FuncTy argTysB retTyB _) =
let argKinds = zipWith checkKinds argTysA argTysB
retKinds = tyToKind retTyA <= tyToKind retTyB
in all (== True) (retKinds : argKinds)
in all (== True) (retKinds : argKinds)
checkKinds t t' = tyToKind t <= tyToKind t'
-- | Put concrete types into the places where there are type variables.
@ -248,11 +260,11 @@ replaceTyVars mappings t =
(FuncTy argTys retTy lt) -> FuncTy (map (replaceTyVars mappings) argTys) (replaceTyVars mappings retTy) (replaceTyVars mappings lt)
(StructTy name tyArgs) ->
case (replaceTyVars mappings name) of
-- special case, struct (f a b) mapped to (RefTy a lt)
-- We f in such a case to the full (Ref a lt) in constraints; we also still map
-- individual members a and b, as these need mappings since they may be
-- referred to in other places (e.g. (Fn [(f a b)] a)--without a mapping,
-- a would remain generic here.
-- special case, struct (f a b) mapped to (RefTy a lt)
-- We f in such a case to the full (Ref a lt) in constraints; we also still map
-- individual members a and b, as these need mappings since they may be
-- referred to in other places (e.g. (Fn [(f a b)] a)--without a mapping,
-- a would remain generic here.
(RefTy a lt) -> (replaceTyVars mappings (RefTy a lt))
_ -> StructTy (replaceTyVars mappings name) (fmap (replaceTyVars mappings) tyArgs)
(PointerTy x) -> PointerTy (replaceTyVars mappings x)

61
src/TypesToC.hs
View File

@ -1,44 +1,47 @@
module TypesToC ( tyToC
, tyToCLambdaFix
, tyToCRawFunctionPtrFix) where
module TypesToC
( tyToC,
tyToCLambdaFix,
tyToCRawFunctionPtrFix,
)
where
import Util
import SymPath
import Types
import Util
tyToC :: Ty -> String
tyToC = tyToCManglePtr False
tyToCLambdaFix :: Ty -> String
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 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 FuncTy{} = "void*"
tyToCRawFunctionPtrFix FuncTy {} = "void*"
tyToCRawFunctionPtrFix t = tyToCManglePtr False t
tyToCManglePtr :: Bool -> Ty -> String
tyToCManglePtr _ IntTy = "int"
tyToCManglePtr _ BoolTy = "bool"
tyToCManglePtr _ FloatTy = "float"
tyToCManglePtr _ DoubleTy = "double"
tyToCManglePtr _ LongTy = "Long"
tyToCManglePtr _ ByteTy = "uint8_t"
tyToCManglePtr _ StringTy = "String"
tyToCManglePtr _ PatternTy = "Pattern"
tyToCManglePtr _ CharTy = "Char"
tyToCManglePtr _ UnitTy = "void"
tyToCManglePtr _ (VarTy x) = x
tyToCManglePtr _ IntTy = "int"
tyToCManglePtr _ BoolTy = "bool"
tyToCManglePtr _ FloatTy = "float"
tyToCManglePtr _ DoubleTy = "double"
tyToCManglePtr _ LongTy = "Long"
tyToCManglePtr _ ByteTy = "uint8_t"
tyToCManglePtr _ StringTy = "String"
tyToCManglePtr _ PatternTy = "Pattern"
tyToCManglePtr _ CharTy = "Char"
tyToCManglePtr _ UnitTy = "void"
tyToCManglePtr _ (VarTy x) = x
tyToCManglePtr _ (FuncTy argTys retTy _) = "Fn__" ++ joinWithUnderscore (map (tyToCManglePtr True) argTys) ++ "_" ++ tyToCManglePtr True retTy
tyToCManglePtr _ ModuleTy = error "Can't emit module type."
tyToCManglePtr b (PointerTy p) = tyToCManglePtr b p ++ (if b then mangle "*" else "*")
tyToCManglePtr b (RefTy r _) = tyToCManglePtr b r ++ (if b then mangle "*" else "*")
tyToCManglePtr _ (StructTy s []) = tyToCManglePtr False s
tyToCManglePtr _ (StructTy s typeArgs) = tyToCManglePtr False s ++ "__" ++ joinWithUnderscore (map (tyToCManglePtr True) typeArgs)
tyToCManglePtr _ (ConcreteNameTy name) = mangle name
tyToCManglePtr _ TypeTy = error "Can't emit the type of types."
tyToCManglePtr _ MacroTy = error "Can't emit the type of macros."
tyToCManglePtr _ DynamicTy = error "Can't emit the type of dynamic functions."
tyToCManglePtr _ ModuleTy = error "Can't emit module type."
tyToCManglePtr b (PointerTy p) = tyToCManglePtr b p ++ (if b then mangle "*" else "*")
tyToCManglePtr b (RefTy r _) = tyToCManglePtr b r ++ (if b then mangle "*" else "*")
tyToCManglePtr _ (StructTy s []) = tyToCManglePtr False s
tyToCManglePtr _ (StructTy s typeArgs) = tyToCManglePtr False s ++ "__" ++ joinWithUnderscore (map (tyToCManglePtr True) typeArgs)
tyToCManglePtr _ (ConcreteNameTy name) = mangle name
tyToCManglePtr _ TypeTy = error "Can't emit the type of types."
tyToCManglePtr _ MacroTy = error "Can't emit the type of macros."
tyToCManglePtr _ DynamicTy = error "Can't emit the type of dynamic functions."

36
src/Util.hs
View File

@ -2,8 +2,8 @@ module Util where
import Data.List
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Maybe (fromMaybe)
import qualified Data.Set as Set
import System.Info (os)
joinWith :: String -> [String] -> String
@ -35,12 +35,13 @@ compilerError msg = error ("Internal compiler error: " ++ msg)
-- | Unwraps a Maybe value a to Right a, or returns a default value (Left b) if it was Nothing.
toEither :: Maybe a -> b -> Either b a
toEither a b = case a of
Just ok -> Right ok
Nothing -> Left b
Just ok -> Right ok
Nothing -> Left b
replaceChars :: Map.Map Char String -> String -> String
replaceChars dict = concatMap replacer
where replacer c = fromMaybe [c] (Map.lookup c dict)
where
replacer c = fromMaybe [c] (Map.lookup c dict)
replaceStrings :: Map.Map String String -> String -> String
replaceStrings dict s = fromMaybe s (Map.lookup s dict)
@ -48,8 +49,8 @@ replaceStrings dict s = fromMaybe s (Map.lookup s dict)
addIfNotPresent :: Eq a => a -> [a] -> [a]
addIfNotPresent x xs =
if x `elem` xs
then xs
else xs ++ [x]
then xs
else xs ++ [x]
remove :: (a -> Bool) -> [a] -> [a]
remove f = filter (not . f)
@ -68,26 +69,26 @@ data Platform = Linux | MacOS | Windows | FreeBSD deriving (Show, Eq)
platform :: Platform
platform =
case os of
"linux" -> Linux
"darwin" -> MacOS
"mingw32" -> Windows
"freebsd" -> FreeBSD
case os of
"linux" -> Linux
"darwin" -> MacOS
"mingw32" -> Windows
"freebsd" -> FreeBSD
unionOfSetsInList :: Ord a => [Set.Set a] -> Set.Set a
unionOfSetsInList (x:xs) =
unionOfSetsInList (x : xs) =
foldl' Set.union x xs
unionOfSetsInList [] =
Set.empty
intersectionOfSetsInList :: Ord a => [Set.Set a] -> Set.Set a
intersectionOfSetsInList (x:xs) =
intersectionOfSetsInList (x : xs) =
foldl' Set.intersection x xs
intersectionOfSetsInList [] =
Set.empty
evenIndices :: [a] -> [a]
evenIndices = map snd . filter (even . fst) . zip ([0..] :: [Int])
evenIndices = map snd . filter (even . fst) . zip ([0 ..] :: [Int])
-- 'Naked' Lmabdas declared at the top level have their own s-expression forms
-- as names, e.g. (fn <> [] ()). This can result in invalid c code. This
@ -95,9 +96,10 @@ evenIndices = map snd . filter (even . fst) . zip ([0..] :: [Int])
-- top level it returns a constant string, otherwise it returns the provided
-- name (usually the name of the function in which the lambda is defined).
lambdaToCName :: String -> Int -> String
lambdaToCName name nestLevel = if nestLevel > 0
then name
else "NAKED_LAMBDA"
lambdaToCName name nestLevel =
if nestLevel > 0
then name
else "NAKED_LAMBDA"
-- Given an integer, create a dummy argument name for it.
-- Called by XObj producing functions such as addCommand.

138
src/Validate.hs
View File

@ -1,41 +1,43 @@
module Validate where
import Data.List (nubBy, (\\))
import Data.Function (on)
import TypeError
import Data.List ((\\), nubBy)
import Lookup
import Obj
import TypeError
import Types
import Util
import Lookup
{-# ANN validateMembers "HLint: ignore Eta reduce" #-}
-- | Make sure that the member declarations in a type definition
-- | Follow the pattern [<name> <type>, <name> <type>, ...]
-- | TODO: This function is only called by the deftype parts of the codebase, which is more specific than the following check implies.
validateMemberCases :: TypeEnv -> [Ty] -> [XObj] -> Either TypeError ()
validateMemberCases typeEnv typeVariables rest = mapM_ visit rest
where visit (XObj (Arr membersXObjs) _ _) =
validateMembers typeEnv typeVariables membersXObjs
visit xobj =
Left (InvalidSumtypeCase xobj)
where
visit (XObj (Arr membersXObjs) _ _) =
validateMembers typeEnv typeVariables membersXObjs
visit xobj =
Left (InvalidSumtypeCase xobj)
validateMembers :: TypeEnv -> [Ty] -> [XObj] -> Either TypeError ()
validateMembers typeEnv typeVariables membersXObjs =
checkUnevenMembers >> checkDuplicateMembers >> checkMembers
where checkUnevenMembers =
if length membersXObjs `mod` 2 == 0
then Right ()
else Left (UnevenMembers membersXObjs)
pairs = pairwise membersXObjs
fields = fst <$> pairs
uniqueFields = nubBy ((==) `on` xobjObj) fields
dups = fields \\ uniqueFields
checkDuplicateMembers =
if length fields == length uniqueFields
then Right ()
else Left (DuplicatedMembers dups)
checkMembers = mapM_ (okXObjForType typeEnv typeVariables . snd) pairs
where
checkUnevenMembers =
if length membersXObjs `mod` 2 == 0
then Right ()
else Left (UnevenMembers membersXObjs)
pairs = pairwise membersXObjs
fields = fst <$> pairs
uniqueFields = nubBy ((==) `on` xobjObj) fields
dups = fields \\ uniqueFields
checkDuplicateMembers =
if length fields == length uniqueFields
then Right ()
else Left (DuplicatedMembers dups)
checkMembers = mapM_ (okXObjForType typeEnv typeVariables . snd) pairs
-- validateOneCase :: XObj -> a
-- validateOneCase XObj {} =
@ -51,59 +53,65 @@ okXObjForType typeEnv typeVariables xobj =
canBeUsedAsMemberType :: TypeEnv -> [Ty] -> Ty -> XObj -> Either TypeError ()
canBeUsedAsMemberType typeEnv typeVariables ty xobj =
case ty of
UnitTy -> pure ()
IntTy -> pure ()
FloatTy -> pure ()
DoubleTy -> pure ()
ByteTy -> pure ()
LongTy -> pure ()
BoolTy -> pure ()
StringTy -> pure ()
UnitTy -> pure ()
IntTy -> pure ()
FloatTy -> pure ()
DoubleTy -> pure ()
ByteTy -> pure ()
LongTy -> pure ()
BoolTy -> pure ()
StringTy -> pure ()
PatternTy -> pure ()
CharTy -> pure ()
FuncTy{} -> pure ()
CharTy -> pure ()
FuncTy {} -> pure ()
PointerTy UnitTy -> pure ()
PointerTy inner -> do _ <- canBeUsedAsMemberType typeEnv typeVariables inner xobj
pure ()
StructTy (ConcreteNameTy "Array") [inner] -> do _ <- canBeUsedAsMemberType typeEnv typeVariables inner xobj
pure ()
PointerTy inner -> do
_ <- canBeUsedAsMemberType typeEnv typeVariables inner xobj
pure ()
StructTy (ConcreteNameTy "Array") [inner] -> do
_ <- canBeUsedAsMemberType typeEnv typeVariables inner xobj
pure ()
StructTy name [tyVars] ->
case name of
(ConcreteNameTy name') ->
-- ensure structs are filled with values
-- Prevents deftypes such as (deftype Player [pos Vector3])
do _ <- canBeUsedAsMemberType typeEnv typeVariables tyVars xobj
case lookupInEnv (SymPath [] name') (getTypeEnv typeEnv) of
Just _ -> pure ()
Nothing -> Left (NotAmongRegisteredTypes ty xobj)
do
_ <- canBeUsedAsMemberType typeEnv typeVariables tyVars xobj
case lookupInEnv (SymPath [] name') (getTypeEnv typeEnv) of
Just _ -> pure ()
Nothing -> Left (NotAmongRegisteredTypes ty xobj)
-- e.g. (deftype (Higher (f a)) (Of [(f a)]))
(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 _ (XObj (Lst (XObj (Deftype t) _ _ : _))_ _))) ->
checkInhabitants t
Just (_, (Binder _ (XObj (Lst (XObj (DefSumtype t) _ _ : _))_ _))) ->
checkInhabitants t
_ -> Left (InvalidMemberType ty xobj)
-- Make sure any struct types have arguments before they can be used as members.
where checkInhabitants t =
case t of
(StructTy _ vars) ->
if length vars == length tyvar
then pure ()
else Left (UninhabitedConstructor ty xobj (length tyvar) (length vars))
_ -> Left (InvalidMemberType ty xobj)
_ -> Left (InvalidMemberType ty xobj)
VarTy _ -> if foldr (||) False (map (isCaptured ty) typeVariables)
then pure ()
else Left (InvalidMemberType ty xobj)
where
-- 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 _) vars) = any (== t) vars
then pure ()
else case name of
(ConcreteNameTy n) ->
case lookupInEnv (SymPath [] n) (getTypeEnv typeEnv) of
Just (_, (Binder _ (XObj (Lst (XObj (Deftype t) _ _ : _)) _ _))) ->
checkInhabitants t
Just (_, (Binder _ (XObj (Lst (XObj (DefSumtype t) _ _ : _)) _ _))) ->
checkInhabitants t
_ -> Left (InvalidMemberType ty xobj)
where
-- Make sure any struct types have arguments before they can be used as members.
checkInhabitants t =
case t of
(StructTy _ vars) ->
if length vars == length tyvar
then pure ()
else Left (UninhabitedConstructor ty xobj (length tyvar) (length vars))
_ -> Left (InvalidMemberType ty xobj)
_ -> Left (InvalidMemberType ty xobj)
VarTy _ ->
if foldr (||) False (map (isCaptured ty) typeVariables)
then pure ()
else Left (InvalidMemberType ty xobj)
where
-- 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 _) vars) = any (== t) vars
_ -> Left (InvalidMemberType ty xobj)

316
test/Spec.hs
View File

@ -1,105 +1,145 @@
import Test.HUnit
import Constraints
import qualified Data.Map as Map
import qualified Data.Set as Set
import Constraints
import Types
import Eval
import Infer
import Obj
import Parsing
import Infer
import Eval
import Test.HUnit
import Types
main :: IO ()
main = do _ <- runTestTT (groupTests "Constraints" testConstraints)
return ()
main = do
_ <- runTestTT (groupTests "Constraints" testConstraints)
return ()
groupTests :: String -> [Test] -> Test
groupTests label testCases =
TestList (zipWith TestLabel (map ((\s -> label ++ " Test " ++ s) . show) [1..]) testCases)
TestList (zipWith TestLabel (map ((\s -> label ++ " Test " ++ s) . show) [1 ..]) testCases)
-- | Helper functions for testing unification of Constraints
isUnificationFailure :: Either UnificationFailure TypeMappings -> Bool
isUnificationFailure (Left _) = True
isUnificationFailure (Left _) = True
isUnificationFailure (Right _) = False
assertUnificationFailure :: [Constraint] -> Test
assertUnificationFailure constraints = TestCase $
assertBool "Failure" (isUnificationFailure (solve constraints))
assertUnificationFailure constraints =
TestCase $
assertBool "Failure" (isUnificationFailure (solve constraints))
assertSolution :: [Constraint] -> [(String, Ty)] -> Test
assertSolution constraints solution = TestCase $
assertEqual "Solution" (Right (Map.fromList solution)) (solve constraints)
assertSolution constraints solution =
TestCase $
assertEqual "Solution" (Right (Map.fromList solution)) (solve constraints)
-- | A dummy XObj
x = XObj (External Nothing) Nothing Nothing
-- | Some type variables
t0 = VarTy "t0"
t1 = VarTy "t1"
t2 = VarTy "t2"
t3 = VarTy "t3"
-- | Test constraints
testConstraints = [testConstr1, testConstr2, testConstr3, testConstr4, testConstr5
,testConstr6, testConstr7, testConstr8, testConstr9, testConstr10
,testConstr11, testConstr12, testConstr13
,testConstr20, testConstr21, testConstr22, testConstr23, testConstr24
-- ,testConstr30 DISABLED FOR NOW, started failing when lifetimes were added to function types TODO: Fix!
,testConstr31, testConstr32, testConstr33
,testConstr34, testConstr35
]
testConstraints =
[ testConstr1,
testConstr2,
testConstr3,
testConstr4,
testConstr5,
testConstr6,
testConstr7,
testConstr8,
testConstr9,
testConstr10,
testConstr11,
testConstr12,
testConstr13,
testConstr20,
testConstr21,
testConstr22,
testConstr23,
testConstr24,
-- ,testConstr30 DISABLED FOR NOW, started failing when lifetimes were added to function types TODO: Fix!
testConstr31,
testConstr32,
testConstr33,
testConstr34,
testConstr35
]
testConstr1 = assertUnificationFailure
[Constraint FloatTy IntTy x x x OrdNo]
testConstr1 =
assertUnificationFailure
[Constraint FloatTy IntTy x x x OrdNo]
testConstr2 = assertSolution
[Constraint IntTy t0 x x x OrdNo]
[("t0", IntTy)]
testConstr2 =
assertSolution
[Constraint IntTy t0 x x x OrdNo]
[("t0", IntTy)]
testConstr3 = assertSolution
[Constraint t0 IntTy x x x OrdNo]
[("t0", IntTy)]
testConstr3 =
assertSolution
[Constraint t0 IntTy x x x OrdNo]
[("t0", IntTy)]
testConstr4 = assertSolution
[Constraint t0 t1 x x x OrdNo, Constraint t0 IntTy x x x OrdNo]
[("t0", IntTy), ("t1", IntTy)]
testConstr4 =
assertSolution
[Constraint t0 t1 x x x OrdNo, Constraint t0 IntTy x x x OrdNo]
[("t0", IntTy), ("t1", IntTy)]
testConstr5 = assertSolution
[Constraint t0 t1 x x x OrdNo, Constraint t1 IntTy x x x OrdNo]
[("t0", IntTy), ("t1", IntTy)]
testConstr5 =
assertSolution
[Constraint t0 t1 x x x OrdNo, Constraint t1 IntTy x x x OrdNo]
[("t0", IntTy), ("t1", IntTy)]
testConstr6 = assertSolution
[Constraint t0 t1 x x x OrdNo, Constraint t1 t3 x x x OrdNo, Constraint t2 IntTy x x x OrdNo, Constraint t3 IntTy x x x OrdNo]
[("t0", IntTy), ("t1", IntTy), ("t2", IntTy), ("t3", IntTy)]
testConstr6 =
assertSolution
[Constraint t0 t1 x x x OrdNo, Constraint t1 t3 x x x OrdNo, Constraint t2 IntTy x x x OrdNo, Constraint t3 IntTy x x x OrdNo]
[("t0", IntTy), ("t1", IntTy), ("t2", IntTy), ("t3", IntTy)]
testConstr7 = assertUnificationFailure
[Constraint t0 IntTy x x x OrdNo, Constraint t0 FloatTy x x x OrdNo]
testConstr7 =
assertUnificationFailure
[Constraint t0 IntTy x x x OrdNo, Constraint t0 FloatTy x x x OrdNo]
testConstr8 = assertSolution
[Constraint t0 IntTy x x x OrdNo, Constraint t0 t0 x x x OrdNo]
[("t0", IntTy)]
testConstr8 =
assertSolution
[Constraint t0 IntTy x x x OrdNo, Constraint t0 t0 x x x OrdNo]
[("t0", IntTy)]
testConstr9 = assertSolution
[Constraint t0 IntTy x x x OrdNo, Constraint t0 t1 x x x OrdNo]
[("t0", IntTy), ("t1", IntTy)]
testConstr9 =
assertSolution
[Constraint t0 IntTy x x x OrdNo, Constraint t0 t1 x x x OrdNo]
[("t0", IntTy), ("t1", IntTy)]
testConstr10 = assertSolution
[Constraint (PointerTy (VarTy "a")) (PointerTy (VarTy "b")) x x x OrdNo]
[("a", (VarTy "a")), ("b", (VarTy "a"))]
testConstr10 =
assertSolution
[Constraint (PointerTy (VarTy "a")) (PointerTy (VarTy "b")) x x x OrdNo]
[("a", (VarTy "a")), ("b", (VarTy "a"))]
testConstr11 = assertSolution
[Constraint (PointerTy (VarTy "a")) (PointerTy (StructTy (ConcreteNameTy "Monkey") [])) x x x OrdNo]
[("a", (StructTy (ConcreteNameTy "Monkey") []))]
testConstr11 =
assertSolution
[Constraint (PointerTy (VarTy "a")) (PointerTy (StructTy (ConcreteNameTy "Monkey") [])) x x x OrdNo]
[("a", (StructTy (ConcreteNameTy "Monkey") []))]
testConstr12 = assertSolution
[Constraint t1 (PointerTy (StructTy (ConcreteNameTy "Array") [IntTy])) x x x OrdNo
,Constraint t1 (PointerTy t2) x x x OrdNo]
[("t1", (PointerTy (StructTy (ConcreteNameTy "Array") [IntTy])))
,("t2", (StructTy (ConcreteNameTy "Array") [IntTy]))]
testConstr12 =
assertSolution
[ Constraint t1 (PointerTy (StructTy (ConcreteNameTy "Array") [IntTy])) x x x OrdNo,
Constraint t1 (PointerTy t2) x x x OrdNo
]
[ ("t1", (PointerTy (StructTy (ConcreteNameTy "Array") [IntTy]))),
("t2", (StructTy (ConcreteNameTy "Array") [IntTy]))
]
testConstr13 = assertSolution
[Constraint t1 CharTy x x x OrdNo
,Constraint t1 CharTy x x x OrdNo]
[("t1", CharTy)]
testConstr13 =
assertSolution
[ Constraint t1 CharTy x x x OrdNo,
Constraint t1 CharTy x x x OrdNo
]
[("t1", CharTy)]
-- -- Should collapse type variables into minimal set:
-- testConstr10 = assertSolution
@ -108,87 +148,109 @@ testConstr13 = assertSolution
-- m7 = solve ([Constraint t1 t2 x x x, Constraint t0 t1 x x x OrdNo])
-- Struct types
testConstr20 = assertSolution
[Constraint t0 (StructTy (ConcreteNameTy "Vector") [t1]) x x x OrdNo
,Constraint t0 (StructTy (ConcreteNameTy "Vector") [IntTy]) x x x OrdNo]
[("t0", (StructTy (ConcreteNameTy "Vector") [IntTy])), ("t1", IntTy)]
testConstr20 =
assertSolution
[ Constraint t0 (StructTy (ConcreteNameTy "Vector") [t1]) x x x OrdNo,
Constraint t0 (StructTy (ConcreteNameTy "Vector") [IntTy]) x x x OrdNo
]
[("t0", (StructTy (ConcreteNameTy "Vector") [IntTy])), ("t1", IntTy)]
testConstr21 = assertSolution
[Constraint t1 (StructTy (ConcreteNameTy "Array") [t2]) x x x OrdNo
,Constraint t1 (StructTy (ConcreteNameTy "Array") [t3]) x x x OrdNo
,Constraint t3 BoolTy x x x OrdNo]
[("t1", (StructTy (ConcreteNameTy "Array") [BoolTy]))
,("t2", BoolTy)
,("t3", BoolTy)]
testConstr21 =
assertSolution
[ Constraint t1 (StructTy (ConcreteNameTy "Array") [t2]) x x x OrdNo,
Constraint t1 (StructTy (ConcreteNameTy "Array") [t3]) x x x OrdNo,
Constraint t3 BoolTy x x x OrdNo
]
[ ("t1", (StructTy (ConcreteNameTy "Array") [BoolTy])),
("t2", BoolTy),
("t3", BoolTy)
]
testConstr22 = assertSolution
[Constraint t1 (StructTy (ConcreteNameTy "Array") [t2]) x x x OrdNo
,Constraint t2 (StructTy (ConcreteNameTy "Array") [t3]) x x x OrdNo
,Constraint t3 FloatTy x x x OrdNo]
[("t1", (StructTy (ConcreteNameTy "Array") [(StructTy (ConcreteNameTy "Array") [FloatTy])]))
,("t2", (StructTy (ConcreteNameTy "Array") [FloatTy]))
,("t3", FloatTy)]
testConstr22 =
assertSolution
[ Constraint t1 (StructTy (ConcreteNameTy "Array") [t2]) x x x OrdNo,
Constraint t2 (StructTy (ConcreteNameTy "Array") [t3]) x x x OrdNo,
Constraint t3 FloatTy x x x OrdNo
]
[ ("t1", (StructTy (ConcreteNameTy "Array") [(StructTy (ConcreteNameTy "Array") [FloatTy])])),
("t2", (StructTy (ConcreteNameTy "Array") [FloatTy])),
("t3", FloatTy)
]
testConstr23 = assertUnificationFailure
[Constraint (StructTy (ConcreteNameTy "Array") [t1]) (StructTy (ConcreteNameTy "Array") [t2]) x x x OrdNo
,Constraint t1 IntTy x x x OrdNo
,Constraint t2 FloatTy x x x OrdNo]
testConstr23 =
assertUnificationFailure
[ Constraint (StructTy (ConcreteNameTy "Array") [t1]) (StructTy (ConcreteNameTy "Array") [t2]) x x x OrdNo,
Constraint t1 IntTy x x x OrdNo,
Constraint t2 FloatTy x x x OrdNo
]
testConstr24 = assertUnificationFailure
[Constraint t2 FloatTy x x x OrdNo
,Constraint t1 IntTy x x x OrdNo
,Constraint (StructTy (ConcreteNameTy "Array") [t1]) (StructTy (ConcreteNameTy "Array") [t2]) x x x OrdNo]
testConstr24 =
assertUnificationFailure
[ Constraint t2 FloatTy x x x OrdNo,
Constraint t1 IntTy x x x OrdNo,
Constraint (StructTy (ConcreteNameTy "Array") [t1]) (StructTy (ConcreteNameTy "Array") [t2]) x x x OrdNo
]
-- m9 = solve [Constraint (StructTy "Vector" [IntTy]) (StructTy "Vector" [t1]) x x x OrdNo]
-- m10 = solve [Constraint (StructTy "Vector" [t1]) (StructTy "Vector" [t2]) x x x OrdNo]
-- Func types
testConstr30 = assertSolution
[Constraint t2 (FuncTy [t0] t1 StaticLifetimeTy) x x x OrdNo
,Constraint t2 (FuncTy [IntTy] BoolTy StaticLifetimeTy) x x x OrdNo]
[("t0", IntTy), ("t1", BoolTy), ("t2", (FuncTy [IntTy] BoolTy StaticLifetimeTy))]
testConstr30 =
assertSolution
[ Constraint t2 (FuncTy [t0] t1 StaticLifetimeTy) x x x OrdNo,
Constraint t2 (FuncTy [IntTy] BoolTy StaticLifetimeTy) x x x OrdNo
]
[("t0", IntTy), ("t1", BoolTy), ("t2", (FuncTy [IntTy] BoolTy StaticLifetimeTy))]
testConstr31 = assertSolution
[Constraint (FuncTy [t0] t1 StaticLifetimeTy) (FuncTy [IntTy] BoolTy StaticLifetimeTy) x x x OrdNo]
[("t0", IntTy), ("t1", BoolTy)]
testConstr31 =
assertSolution
[Constraint (FuncTy [t0] t1 StaticLifetimeTy) (FuncTy [IntTy] BoolTy StaticLifetimeTy) x x x OrdNo]
[("t0", IntTy), ("t1", BoolTy)]
testConstr32 = assertSolution
[Constraint t0 (FuncTy [IntTy] BoolTy StaticLifetimeTy) x x x OrdNo]
[("t0", (FuncTy [IntTy] BoolTy StaticLifetimeTy))]
testConstr32 =
assertSolution
[Constraint t0 (FuncTy [IntTy] BoolTy StaticLifetimeTy) x x x OrdNo]
[("t0", (FuncTy [IntTy] BoolTy StaticLifetimeTy))]
testConstr33 = assertSolution
[Constraint t1 (FuncTy [t2] IntTy StaticLifetimeTy) x x x OrdNo
,Constraint t1 (FuncTy [t3] IntTy StaticLifetimeTy) x x x OrdNo
,Constraint t3 BoolTy x x x OrdNo]
[("t1", (FuncTy [BoolTy] IntTy StaticLifetimeTy))
,("t2", BoolTy)
,("t3", BoolTy)]
testConstr33 =
assertSolution
[ Constraint t1 (FuncTy [t2] IntTy StaticLifetimeTy) x x x OrdNo,
Constraint t1 (FuncTy [t3] IntTy StaticLifetimeTy) x x x OrdNo,
Constraint t3 BoolTy x x x OrdNo
]
[ ("t1", (FuncTy [BoolTy] IntTy StaticLifetimeTy)),
("t2", BoolTy),
("t3", BoolTy)
]
testConstr34 = assertSolution
[Constraint (VarTy "a") (StructTy (ConcreteNameTy "Pair") [(VarTy "x0"), (VarTy "y0")]) x x x OrdNo
,Constraint (StructTy (ConcreteNameTy "Array") [(VarTy "a")]) (StructTy (ConcreteNameTy "Array") [(StructTy (ConcreteNameTy "Pair") [(VarTy "x1"), (VarTy "y1")])]) x x x OrdNo]
[("a", (StructTy (ConcreteNameTy "Pair") [(VarTy "x0"), (VarTy "y0")]))
,("x0", (VarTy "x0"))
,("y0", (VarTy "y0"))
,("x1", (VarTy "x0"))
,("y1", (VarTy "y0"))
]
testConstr34 =
assertSolution
[ Constraint (VarTy "a") (StructTy (ConcreteNameTy "Pair") [(VarTy "x0"), (VarTy "y0")]) x x x OrdNo,
Constraint (StructTy (ConcreteNameTy "Array") [(VarTy "a")]) (StructTy (ConcreteNameTy "Array") [(StructTy (ConcreteNameTy "Pair") [(VarTy "x1"), (VarTy "y1")])]) x x x OrdNo
]
[ ("a", (StructTy (ConcreteNameTy "Pair") [(VarTy "x0"), (VarTy "y0")])),
("x0", (VarTy "x0")),
("y0", (VarTy "y0")),
("x1", (VarTy "x0")),
("y1", (VarTy "y0"))
]
-- Same as testConstr34, except everything is wrapped in refs
testConstr35 = assertSolution
[Constraint (RefTy (VarTy "a") (VarTy "lt0")) (RefTy (StructTy (ConcreteNameTy "Pair") [(VarTy "x0"), (VarTy "y0")]) (VarTy "lt1")) x x x OrdNo
,Constraint (RefTy (StructTy (ConcreteNameTy "Array") [(VarTy "a")]) (VarTy "lt2")) (RefTy (StructTy (ConcreteNameTy "Array") [(StructTy (ConcreteNameTy "Pair") [(VarTy "x1"), (VarTy "y1")])]) (VarTy "lt3")) x x x OrdNo]
[("a", (StructTy (ConcreteNameTy "Pair") [(VarTy "x0"), (VarTy "y0")]))
,("x0", (VarTy "x0"))
,("y0", (VarTy "y0"))
,("x1", (VarTy "x0"))
,("y1", (VarTy "y0"))
,("lt0", (VarTy "lt0"))
,("lt1", (VarTy "lt0"))
,("lt2", (VarTy "lt2"))
,("lt3", (VarTy "lt2"))
]
testConstr35 =
assertSolution
[ Constraint (RefTy (VarTy "a") (VarTy "lt0")) (RefTy (StructTy (ConcreteNameTy "Pair") [(VarTy "x0"), (VarTy "y0")]) (VarTy "lt1")) x x x OrdNo,
Constraint (RefTy (StructTy (ConcreteNameTy "Array") [(VarTy "a")]) (VarTy "lt2")) (RefTy (StructTy (ConcreteNameTy "Array") [(StructTy (ConcreteNameTy "Pair") [(VarTy "x1"), (VarTy "y1")])]) (VarTy "lt3")) x x x OrdNo
]
[ ("a", (StructTy (ConcreteNameTy "Pair") [(VarTy "x0"), (VarTy "y0")])),
("x0", (VarTy "x0")),
("y0", (VarTy "y0")),
("x1", (VarTy "x0")),
("y1", (VarTy "y0")),
("lt0", (VarTy "lt0")),
("lt1", (VarTy "lt0")),
("lt2", (VarTy "lt2")),
("lt3", (VarTy "lt2"))
]
-- Ref types with lifetimes
-- testConstr36 = assertSolution
-- [Constraint (RefTy (VarTy "a")) (RefTy (StructTy "Pair" [(VarTy "x0"), (VarTy "y0")])) x x x OrdNo