carp-lang/Carp
1
1
Fork 0
mirror of https://github.com/carp-lang/Carp.git synced 2024-11-20 11:02:01 +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 import Distribution.Simple
main = defaultMain main = defaultMain

349
app/Main.hs
View File

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

318
headerparse/Main.hs
View File

@ -3,35 +3,51 @@
module Main where module Main where
import Options.Applicative hiding ((<|>)) import Data.Char (isUpper, toLower)
import Text.Parsec ((<|>))
import qualified Text.Parsec as Parsec
import Data.Char (toLower, isUpper)
import Util
import Types
import Obj import Obj
import Options.Applicative hiding ((<|>))
import Path import Path
import Reify import Reify
import Text.Parsec ((<|>))
import qualified Text.Parsec as Parsec
import Types
import Util
data Args = Args { prefixToRemove :: String data Args
, kebabCase :: Bool = Args
, sourcePath :: String { prefixToRemove :: String,
} deriving Show kebabCase :: Bool,
sourcePath :: String
}
deriving (Show)
parseArgs :: Parser Args parseArgs :: Parser Args
parseArgs = Args parseArgs =
<$> strOption (long "prefixtoremove" <> short 'p' <> metavar "ITEM" <> value "") Args
<*> switch (long "kebabcase" <> short 'f') <$> strOption (long "prefixtoremove" <> short 'p' <> metavar "ITEM" <> value "")
<*> argument str (metavar "FILE") <*> switch (long "kebabcase" <> short 'f')
<*> argument str (metavar "FILE")
main = do parsedArgs <- execParser $ Options.Applicative.info (parseArgs <**> helper) fullDesc main = do
let path = sourcePath parsedArgs parsedArgs <- execParser $ Options.Applicative.info (parseArgs <**> helper) fullDesc
if path /= "" let path = sourcePath parsedArgs
then do source <- slurp path if path /= ""
putStrLn (joinWith "\n" (map pretty (parseHeaderFile path source then do
(prefixToRemove parsedArgs) source <- slurp path
(kebabCase parsedArgs)))) putStrLn
else print parsedArgs ( joinWith
"\n"
( map
pretty
( parseHeaderFile
path
source
(prefixToRemove parsedArgs)
(kebabCase parsedArgs)
)
)
)
else print parsedArgs
parseHeaderFile :: FilePath -> String -> String -> Bool -> [XObj] parseHeaderFile :: FilePath -> String -> String -> Bool -> [XObj]
parseHeaderFile path src prefix kebab = parseHeaderFile path src prefix kebab =
@ -39,130 +55,148 @@ parseHeaderFile path src prefix kebab =
Left err -> error (show err) Left err -> error (show err)
Right ok -> concat ok Right ok -> concat ok
where where
cSyntax :: Parsec.Parsec String () [[XObj]] cSyntax :: Parsec.Parsec String () [[XObj]]
cSyntax = Parsec.sepBy line (Parsec.char '\n') 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] --pure [(XObj (Str ("DISCARDED: " ++ discardedLine)) Nothing Nothing)]
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)]
createRegisterForm :: String -> XObj -> String -> Bool -> [XObj] createRegisterForm :: String -> XObj -> String -> Bool -> [XObj]
createRegisterForm name tyXObj prefix kebab = createRegisterForm name tyXObj prefix kebab =
let carpName = (if kebab then (toKebab . lowerFirst) else id) let carpName =
(if prefix == "" then name else removePrefix prefix name) (if kebab then (toKebab . lowerFirst) else id)
(if prefix == "" then name else removePrefix prefix name)
emitName = name emitName = name
in [XObj (Lst ([ (XObj (Sym (SymPath [] "register") Symbol) Nothing Nothing) in [ XObj
, (XObj (Sym (SymPath [] carpName) Symbol) Nothing Nothing) ( Lst
, tyXObj ( [ (XObj (Sym (SymPath [] "register") Symbol) Nothing Nothing),
] ++ (XObj (Sym (SymPath [] carpName) Symbol) Nothing Nothing),
if prefix == "" tyXObj
then [] ]
else [(XObj (Str emitName) Nothing Nothing)] ++ if prefix == ""
)) Nothing Nothing] then []
else [(XObj (Str emitName) Nothing Nothing)]
)
)
Nothing
Nothing
]
toFnTypeXObj :: [(String, Int)] -> (String, Int) -> XObj toFnTypeXObj :: [(String, Int)] -> (String, Int) -> XObj
toFnTypeXObj argTypeStrings returnTypeString = toFnTypeXObj argTypeStrings returnTypeString =
(XObj (Lst [ (XObj (Sym (SymPath [] "λ") Symbol) Nothing Nothing) ( XObj
, (XObj (Arr (map (reify . cTypeToCarpType) argTypeStrings)) Nothing Nothing) ( Lst
, (XObj (Sym (SymPath [] (show (cTypeToCarpType returnTypeString))) Symbol) Nothing Nothing) [ (XObj (Sym (SymPath [] "λ") Symbol) Nothing Nothing),
]) 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 :: (String, Int) -> XObj
toTypeXObj typeString = toTypeXObj typeString =
@ -187,9 +221,11 @@ removePrefix prefix s =
case Parsec.runParser match () "" s of case Parsec.runParser match () "" s of
Left err -> s Left err -> s
Right ok -> ok Right ok -> ok
where match = where
do _ <- Parsec.string prefix match =
Parsec.many1 identifierChar do
_ <- Parsec.string prefix
Parsec.many1 identifierChar
lowerFirst :: String -> String lowerFirst :: String -> String
lowerFirst (c : cs) = toLower c : cs lowerFirst (c : cs) = toLower c : cs

766
src/ArrayTemplates.hs
View File

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

50
src/AssignTypes.hs
View File

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

13
src/ColorText.hs
View File

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

646
src/Commands.hs
View File

@ -1,37 +1,35 @@
module Commands where module Commands where
import Prelude hiding (abs) import ColorText
import Control.Exception import Control.Exception
import Control.Monad (join, when) 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.Bits (finiteBitSize)
import Data.List (elemIndex) import Data.List (elemIndex)
import Data.List.Split (splitOn) 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 qualified Data.Map as Map
import Data.Maybe (fromMaybe)
import Emit import Emit
import Obj
import Project
import Types
import ColorText
import Util
import Lookup
import RenderDocs
import TypeError
import Path
import Info import Info
import Lookup
import qualified Meta import qualified Meta
import Obj
import Path
import Project
import Reify 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
data CarpException = = ShellOutException {shellOutMessage :: String, returnCode :: Int}
ShellOutException { shellOutMessage :: String, returnCode :: Int }
| CancelEvaluationException | CancelEvaluationException
| EvalException EvalError | EvalException EvalError
deriving (Eq, Show) 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 :: SymPath -> Maybe Int -> CommandCallback -> String -> String -> (String, Binder)
addCommandConfigurable path maybeArity callback doc example = addCommandConfigurable path maybeArity callback doc example =
let cmd = XObj (Lst [XObj (Command (CommandFunction f)) (Just dummyInfo) Nothing let cmd =
,XObj (Sym path Symbol) Nothing Nothing XObj
,unfoldArgs ( Lst
]) [ XObj (Command (CommandFunction f)) (Just dummyInfo) Nothing,
(Just dummyInfo) (Just DynamicTy) XObj (Sym path Symbol) Nothing Nothing,
unfoldArgs
]
)
(Just dummyInfo)
(Just DynamicTy)
SymPath _ name = path SymPath _ name = path
meta = Meta.set "doc" (XObj (Str docString) Nothing Nothing) emptyMeta meta = Meta.set "doc" (XObj (Str docString) Nothing Nothing) emptyMeta
in (name, Binder meta cmd) in (name, Binder meta cmd)
where f = case maybeArity of where
Just arity -> withArity arity f = case maybeArity of
Nothing -> callback Just arity -> withArity arity
docString = doc ++ "\n\n" ++ exampleUsage Nothing -> callback
exampleUsage = "Example Usage:\n```\n" ++ example ++ "\n```\n" docString = doc ++ "\n\n" ++ exampleUsage
withArity arity ctx args = exampleUsage = "Example Usage:\n```\n" ++ example ++ "\n```\n"
if length args == arity withArity arity ctx args =
then callback ctx args if length args == arity
else then callback ctx args
pure (evalError ctx ("Invalid args to '" ++ show path ++ "' command: " ++ joinWithComma (map pretty args) ++ "\n\n" ++ exampleUsage) Nothing) else pure (evalError ctx ("Invalid args to '" ++ show path ++ "' command: " ++ joinWithComma (map pretty args) ++ "\n\n" ++ exampleUsage) Nothing)
unfoldArgs = unfoldArgs =
case maybeArity of case maybeArity of
Just arity -> Just arity ->
let tosym x = (XObj (Sym (SymPath [] x) Symbol) Nothing Nothing) let tosym x = (XObj (Sym (SymPath [] x) Symbol) Nothing Nothing)
in XObj (Arr (map (tosym . intToArgName) [1..arity])) Nothing Nothing in XObj (Arr (map (tosym . intToArgName) [1 .. arity])) Nothing Nothing
Nothing -> XObj (Arr [(XObj (Sym (SymPath [] "") Symbol) Nothing Nothing)]) Nothing Nothing Nothing -> XObj (Arr [(XObj (Sym (SymPath [] "") Symbol) Nothing Nothing)]) Nothing Nothing
presentErrorWithLabel :: MonadIO m => String -> String -> a -> m a presentErrorWithLabel :: MonadIO m => String -> String -> a -> m a
presentErrorWithLabel label msg ret = presentErrorWithLabel label msg ret =
liftIO $ do emitErrorWithLabel label msg liftIO $ do
pure ret emitErrorWithLabel label msg
pure ret
presentError :: MonadIO m => String -> a -> m a presentError :: MonadIO m => String -> a -> m a
presentError msg ret = presentError msg ret =
liftIO $ do emitError msg liftIO $ do
pure ret emitError msg
pure ret
-- | Command for changing various project settings. -- | Command for changing various project settings.
commandProjectConfig :: CommandCallback commandProjectConfig :: CommandCallback
commandProjectConfig ctx [xobj@(XObj (Str key) _ _), value] = do commandProjectConfig ctx [xobj@(XObj (Str key) _ _), value] = do
let proj = contextProj ctx let proj = contextProj ctx
newProj = case key of newProj = case key of
"cflag" -> do cflag <- unwrapStringXObj value "cflag" -> do
pure (proj { projectCFlags = addIfNotPresent cflag (projectCFlags proj) }) cflag <- unwrapStringXObj value
"libflag" -> do libflag <- unwrapStringXObj value pure (proj {projectCFlags = addIfNotPresent cflag (projectCFlags proj)})
pure (proj { projectLibFlags = addIfNotPresent libflag (projectLibFlags proj) }) "libflag" -> do
"pkgconfigflag" -> do pkgconfigflag <- unwrapStringXObj value libflag <- unwrapStringXObj value
pure (proj { projectPkgConfigFlags = addIfNotPresent pkgconfigflag (projectPkgConfigFlags proj) }) pure (proj {projectLibFlags = addIfNotPresent libflag (projectLibFlags proj)})
"cmod" -> do cmod <- unwrapStringXObj value "pkgconfigflag" -> do
pure (proj { projectCModules = addIfNotPresent cmod (projectCModules proj) }) pkgconfigflag <- unwrapStringXObj value
"prompt" -> do prompt <- unwrapStringXObj value pure (proj {projectPkgConfigFlags = addIfNotPresent pkgconfigflag (projectPkgConfigFlags proj)})
pure (proj { projectPrompt = prompt }) "cmod" -> do
"search-path" -> do searchPath <- unwrapStringXObj value cmod <- unwrapStringXObj value
pure (proj { projectCarpSearchPaths = addIfNotPresent searchPath (projectCarpSearchPaths proj) }) pure (proj {projectCModules = addIfNotPresent cmod (projectCModules proj)})
"print-ast" -> do printAST <- unwrapBoolXObj value "prompt" -> do
pure (proj { projectPrintTypedAST = printAST }) prompt <- unwrapStringXObj value
"echo-c" -> do echoC <- unwrapBoolXObj value pure (proj {projectPrompt = prompt})
pure (proj { projectEchoC = echoC }) "search-path" -> do
"echo-compiler-cmd" -> do echoCompilerCmd <- unwrapBoolXObj value searchPath <- unwrapStringXObj value
pure (proj { projectEchoCompilationCommand = echoCompilerCmd }) pure (proj {projectCarpSearchPaths = addIfNotPresent searchPath (projectCarpSearchPaths proj)})
"compiler" -> do compiler <- unwrapStringXObj value "print-ast" -> do
pure (proj { projectCompiler = compiler }) printAST <- unwrapBoolXObj value
"target" -> do target <- unwrapStringXObj value pure (proj {projectPrintTypedAST = printAST})
pure (proj { projectTarget = Target target }) "echo-c" -> do
"title" -> do title <- unwrapStringXObj value echoC <- unwrapBoolXObj value
pure (proj { projectTitle = title }) pure (proj {projectEchoC = echoC})
"output-directory" -> do outDir <- unwrapStringXObj value "echo-compiler-cmd" -> do
pure (proj { projectOutDir = outDir }) echoCompilerCmd <- unwrapBoolXObj value
"docs-directory" -> do docsDir <- unwrapStringXObj value pure (proj {projectEchoCompilationCommand = echoCompilerCmd})
pure (proj { projectDocsDir = docsDir }) "compiler" -> do
"docs-generate-index" -> compiler <- unwrapStringXObj value
do docsGenerateIndex <- unwrapBoolXObj value pure (proj {projectCompiler = compiler})
pure (proj { projectDocsGenerateIndex = docsGenerateIndex }) "target" -> do
"docs-logo" -> do logo <- unwrapStringXObj value target <- unwrapStringXObj value
pure (proj { projectDocsLogo = logo }) pure (proj {projectTarget = Target target})
"docs-prelude" -> do prelude <- unwrapStringXObj value "title" -> do
pure (proj { projectDocsPrelude = prelude }) title <- unwrapStringXObj value
"docs-url" -> do url <- unwrapStringXObj value pure (proj {projectTitle = title})
pure (proj { projectDocsURL = url }) "output-directory" -> do
"docs-styling" -> do url <- unwrapStringXObj value outDir <- unwrapStringXObj value
pure (proj { projectDocsStyling = url }) pure (proj {projectOutDir = outDir})
"file-path-print-length" -> do len <- unwrapStringXObj value "docs-directory" -> do
case len of docsDir <- unwrapStringXObj value
"short" -> pure (proj { projectFilePathPrintLength = ShortPath }) pure (proj {projectDocsDir = docsDir})
"full" -> pure (proj { projectFilePathPrintLength = ShortPath }) "docs-generate-index" ->
_ -> Left ("Project.config can't understand the value '" ++ len ++ "' for key 'file-path-print-length.") do
"generate-only" -> do generateOnly <- unwrapBoolXObj value docsGenerateIndex <- unwrapBoolXObj value
pure (proj { projectGenerateOnly = generateOnly }) pure (proj {projectDocsGenerateIndex = docsGenerateIndex})
"paren-balance-hints" -> "docs-logo" -> do
do balanceHints <- unwrapBoolXObj value logo <- unwrapStringXObj value
pure (proj { projectBalanceHints = balanceHints }) pure (proj {projectDocsLogo = logo})
"force-reload" -> do forceReload <- unwrapBoolXObj value "docs-prelude" -> do
pure (proj { projectForceReload = forceReload }) prelude <- unwrapStringXObj value
_ -> Left ("Project.config can't understand the key '" ++ key ++ "' at " ++ prettyInfoFromXObj xobj ++ ".") 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 case newProj of
Left errorMessage -> presentErrorWithLabel "CONFIG ERROR" errorMessage (ctx, dynamicNil) 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, _] = commandProjectConfig ctx [faultyKey, _] =
presentError ("First argument to 'Project.config' must be a string: " ++ pretty faultyKey) (ctx, dynamicNil) 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 let proj = contextProj ctx
xstr s = XObj s (Just dummyInfo) (Just StringTy) xstr s = XObj s (Just dummyInfo) (Just StringTy)
getVal _ = case key of getVal _ = case key of
"cflag" -> Right $ Str $ show $ projectCFlags proj "cflag" -> Right $ Str $ show $ projectCFlags proj
"libflag" -> Right $ Str $ show $ projectLibFlags proj "libflag" -> Right $ Str $ show $ projectLibFlags proj
"pkgconfigflag" -> Right $ Arr $ xstr . Str <$> projectPkgConfigFlags proj "pkgconfigflag" -> Right $ Arr $ xstr . Str <$> projectPkgConfigFlags proj
"load-stack" -> Right $ Arr $ xstr . Str <$> projectLoadStack proj "load-stack" -> Right $ Arr $ xstr . Str <$> projectLoadStack proj
"prompt" -> Right $ Str $ projectPrompt proj "prompt" -> Right $ Str $ projectPrompt proj
"search-path" -> Right $ Str $ show $ projectCarpSearchPaths proj "search-path" -> Right $ Str $ show $ projectCarpSearchPaths proj
"print-ast" -> Right $ Bol $ projectPrintTypedAST proj "print-ast" -> Right $ Bol $ projectPrintTypedAST proj
"echo-c" -> Right $ Bol $ projectEchoC proj "echo-c" -> Right $ Bol $ projectEchoC proj
"echo-compiler-cmd" -> Right $ Bol $ projectEchoCompilationCommand proj "echo-compiler-cmd" -> Right $ Bol $ projectEchoCompilationCommand proj
"compiler" -> Right $ Str $ projectCompiler proj "compiler" -> Right $ Str $ projectCompiler proj
"target" -> Right $ Str $ show $ projectTarget proj "target" -> Right $ Str $ show $ projectTarget proj
"title" -> Right $ Str $ projectTitle proj "title" -> Right $ Str $ projectTitle proj
"output-directory" -> Right $ Str $ projectOutDir proj "output-directory" -> Right $ Str $ projectOutDir proj
"docs-directory" -> Right $ Str $ projectDocsDir proj "docs-directory" -> Right $ Str $ projectDocsDir proj
"docs-logo" -> Right $ Str $ projectDocsLogo proj "docs-logo" -> Right $ Str $ projectDocsLogo proj
"docs-prelude" -> Right $ Str $ projectDocsPrelude proj "docs-prelude" -> Right $ Str $ projectDocsPrelude proj
"docs-url" -> Right $ Str $ projectDocsURL proj "docs-url" -> Right $ Str $ projectDocsURL proj
"docs-generate-index" -> Right $ Bol $ projectDocsGenerateIndex proj "docs-generate-index" -> Right $ Bol $ projectDocsGenerateIndex proj
"docs-styling" -> Right $ Str $ projectDocsStyling proj "docs-styling" -> Right $ Str $ projectDocsStyling proj
"file-path-print-length" -> Right $ Str $ show (projectFilePathPrintLength proj) "file-path-print-length" -> Right $ Str $ show (projectFilePathPrintLength proj)
"generate-only" -> Right $ Bol $ projectGenerateOnly proj "generate-only" -> Right $ Bol $ projectGenerateOnly proj
"paren-balance-hints" -> Right $ Bol $ projectBalanceHints proj "paren-balance-hints" -> Right $ Bol $ projectBalanceHints proj
_ -> Left key _ -> Left key
in pure $ case getVal ctx of in pure $ case getVal ctx of
Right val -> (ctx, Right $ xstr val) Right val -> (ctx, Right $ xstr val)
Left k -> (evalError ctx (labelStr "CONFIG ERROR" ("Project.get-config can't understand the key '" ++ k)) (xobjInfo xobj)) Left k -> (evalError ctx (labelStr "CONFIG ERROR" ("Project.get-config can't understand the key '" ++ k)) (xobjInfo xobj))
commandProjectGetConfig ctx [faultyKey] = commandProjectGetConfig ctx [faultyKey] =
presentError ("First argument to 'Project.config' must be a string: " ++ pretty faultyKey) (ctx, dynamicNil) presentError ("First argument to 'Project.config' must be a string: " ++ pretty faultyKey) (ctx, dynamicNil)
-- | Command for exiting the REPL/compiler -- | Command for exiting the REPL/compiler
commandQuit :: CommandCallback commandQuit :: CommandCallback
commandQuit ctx _ = commandQuit ctx _ =
do _ <- liftIO exitSuccess do
pure (ctx, dynamicNil) _ <- liftIO exitSuccess
pure (ctx, dynamicNil)
-- | Command for printing the generated C output (in out/main.c) -- | Command for printing the generated C output (in out/main.c)
commandCat :: CommandCallback commandCat :: CommandCallback
commandCat ctx _ = do commandCat ctx _ = do
let outDir = projectOutDir (contextProj ctx) let outDir = projectOutDir (contextProj ctx)
outMain = outDir </> "main.c" outMain = outDir </> "main.c"
liftIO $ do callCommand ("cat -n " ++ outMain) liftIO $ do
pure (ctx, dynamicNil) callCommand ("cat -n " ++ outMain)
pure (ctx, dynamicNil)
-- | Command for running the executable generated by the 'build' command. -- | Command for running the executable generated by the 'build' command.
commandRunExe :: CommandCallback commandRunExe :: CommandCallback
@ -215,13 +244,15 @@ commandRunExe ctx _ = do
quoted x = "\"" ++ x ++ "\"" quoted x = "\"" ++ x ++ "\""
outExe = quoted $ outDir </> projectTitle (contextProj ctx) outExe = quoted $ outDir </> projectTitle (contextProj ctx)
if projectCanExecute proj if projectCanExecute proj
then liftIO $ do hndl <- spawnCommand outExe then liftIO $ do
exitCode <- waitForProcess hndl hndl <- spawnCommand outExe
case exitCode of exitCode <- waitForProcess hndl
ExitSuccess -> pure (ctx, Right (XObj (Num IntTy 0) (Just dummyInfo) (Just IntTy))) case exitCode of
ExitFailure i -> throw (ShellOutException ("'" ++ outExe ++ "' exited with return value " ++ show i ++ ".") i) ExitSuccess -> pure (ctx, Right (XObj (Num IntTy 0) (Just dummyInfo) (Just IntTy)))
else liftIO $ do putStrLnWithColor Red "Can't call the 'run' command, need to build an executable first (requires a 'main' function)." ExitFailure i -> throw (ShellOutException ("'" ++ outExe ++ "' exited with return value " ++ show i ++ ".") i)
pure (ctx, dynamicNil) 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. -- | Command for building the project, producing an executable binary or a shared library.
commandBuild :: Bool -> Context -> [XObj] -> IO (Context, Either EvalError XObj) commandBuild :: Bool -> Context -> [XObj] -> IO (Context, Either EvalError XObj)
@ -230,75 +261,88 @@ commandBuild shutUp ctx _ = do
typeEnv = contextTypeEnv ctx typeEnv = contextTypeEnv ctx
proj = contextProj ctx proj = contextProj ctx
execMode = contextExecMode ctx execMode = contextExecMode ctx
src = do decl <- envToDeclarations typeEnv env src = do
typeDecl <- envToDeclarations typeEnv (getTypeEnv typeEnv) decl <- envToDeclarations typeEnv env
c <- envToC env Functions typeDecl <- envToDeclarations typeEnv (getTypeEnv typeEnv)
initGlobals <- fmap (wrapInInitFunction (projectCore proj)) (globalsToC env) c <- envToC env Functions
pure ("//Types:\n" ++ typeDecl ++ initGlobals <- fmap (wrapInInitFunction (projectCore proj)) (globalsToC env)
"\n\n//Declarations:\n" ++ decl ++ pure
"\n\n//Init globals:\n" ++ initGlobals ++ ( "//Types:\n" ++ typeDecl
"\n\n//Definitions:\n" ++ c ++ "\n\n//Declarations:\n"
) ++ decl
++ "\n\n//Init globals:\n"
++ initGlobals
++ "\n\n//Definitions:\n"
++ c
)
case src of case src of
Left err -> Left err ->
pure (evalError ctx ("I encountered an error when emitting code:\n\n" ++ show err) Nothing) pure (evalError ctx ("I encountered an error when emitting code:\n\n" ++ show err) Nothing)
Right okSrc -> Right okSrc ->
do let compiler = projectCompiler proj do
echoCompilationCommand = projectEchoCompilationCommand proj let compiler = projectCompiler proj
incl = projectIncludesToC proj echoCompilationCommand = projectEchoCompilationCommand proj
includeCorePath = projectCarpDir proj ++ "/core/ " incl = projectIncludesToC proj
cModules = projectCModules proj includeCorePath = projectCarpDir proj ++ "/core/ "
flags = projectFlags proj cModules = projectCModules proj
outDir = projectOutDir proj flags = projectFlags proj
outMain = outDir </> "main.c" outDir = projectOutDir proj
outExe = outDir </> projectTitle proj outMain = outDir </> "main.c"
generateOnly = projectGenerateOnly proj outExe = outDir </> projectTitle proj
compile hasMain = generateOnly = projectGenerateOnly proj
do let cmd = joinWithSpace $ [ compiler compile hasMain =
, if hasMain then "" else "-shared" do
, "-o" let cmd =
, outExe joinWithSpace $
, "-I" [ compiler,
, includeCorePath if hasMain then "" else "-shared",
, flags "-o",
, outMain outExe,
] ++ cModules "-I",
in liftIO $ do when echoCompilationCommand (putStrLn cmd) includeCorePath,
callCommand cmd flags,
when (execMode == Repl && not shutUp) $ outMain
(putStrLn ("Compiled to '" ++ outExe ++ (if hasMain then "' (executable)" else "' (shared library)"))) ]
pure (setProjectCanExecute hasMain ctx, dynamicNil) ++ cModules
liftIO $ createDirectoryIfMissing False outDir in liftIO $ do
outputHandle <- openFile outMain WriteMode when echoCompilationCommand (putStrLn cmd)
hSetEncoding outputHandle utf8 callCommand cmd
hPutStr outputHandle (incl ++ okSrc) when (execMode == Repl && not shutUp) $
hClose outputHandle (putStrLn ("Compiled to '" ++ outExe ++ (if hasMain then "' (executable)" else "' (shared library)")))
if generateOnly then pure (ctx, dynamicNil) else pure (setProjectCanExecute hasMain ctx, dynamicNil)
case Map.lookup "main" (envBindings env) of liftIO $ createDirectoryIfMissing False outDir
Just _ -> compile True outputHandle <- openFile outMain WriteMode
Nothing -> compile False 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 :: Bool -> Context -> Context
setProjectCanExecute value ctx = setProjectCanExecute value ctx =
let proj = contextProj ctx let proj = contextProj ctx
proj' = proj { projectCanExecute = value } proj' = proj {projectCanExecute = value}
in ctx { contextProj = proj' } in ctx {contextProj = proj'}
-- | Command for printing all the bindings in the current environment. -- | Command for printing all the bindings in the current environment.
commandListBindings :: CommandCallback commandListBindings :: CommandCallback
commandListBindings ctx _ = commandListBindings ctx _ =
liftIO $ do putStrLn "Types:\n" liftIO $ do
putStrLn (prettyEnvironment (getTypeEnv (contextTypeEnv ctx))) putStrLn "Types:\n"
putStrLn "\nGlobal environment:\n" putStrLn (prettyEnvironment (getTypeEnv (contextTypeEnv ctx)))
putStrLn (prettyEnvironment (contextGlobalEnv ctx)) putStrLn "\nGlobal environment:\n"
putStrLn "" putStrLn (prettyEnvironment (contextGlobalEnv ctx))
pure (ctx, dynamicNil) putStrLn ""
pure (ctx, dynamicNil)
-- | Command for printing information about the current project. -- | Command for printing information about the current project.
commandProject :: CommandCallback commandProject :: CommandCallback
commandProject ctx _ = do commandProject ctx _ = do
liftIO (print (contextProj ctx)) liftIO (print (contextProj ctx))
pure (ctx, dynamicNil) pure (ctx, dynamicNil)
-- | Command for getting the name of the operating system you're on. -- | Command for getting the name of the operating system you're on.
commandHostOS :: CommandCallback commandHostOS :: CommandCallback
@ -318,11 +362,12 @@ commandAddInclude includerConstructor ctx [x] =
let proj = contextProj ctx let proj = contextProj ctx
includer = includerConstructor file includer = includerConstructor file
includers = projectIncludes proj includers = projectIncludes proj
includers' = if includer `elem` includers includers' =
then includers if includer `elem` includers
else includers ++ [includer] -- Add last to preserve include order then includers
proj' = proj { projectIncludes = includers' } else includers ++ [includer] -- Add last to preserve include order
pure (ctx { contextProj = proj' }, dynamicNil) 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)) 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] = commandAddRelativeInclude ctx [x] =
case x of case x of
XObj (Str file) i@(Just info) t -> XObj (Str file) i@(Just info) t ->
let compiledFile = infoFile info let compiledFile = infoFile info
in commandAddInclude RelativeInclude ctx [ in commandAddInclude
XObj (Str $ takeDirectory compiledFile </> file) i t 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)) 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 :: CommandCallback
commandLast ctx [x] = commandLast ctx [x] =
pure $ case x of pure $ case x of
XObj (Lst lst@(_:_)) _ _ -> (ctx, Right (last lst)) XObj (Lst lst@(_ : _)) _ _ -> (ctx, Right (last lst))
XObj (Arr arr@(_:_)) _ _ -> (ctx, Right (last arr)) XObj (Arr arr@(_ : _)) _ _ -> (ctx, Right (last arr))
_ -> evalError ctx "Applying 'last' to non-list or empty list." (xobjInfo x) _ -> evalError ctx "Applying 'last' to non-list or empty list." (xobjInfo x)
commandAllButLast :: CommandCallback commandAllButLast :: CommandCallback
@ -430,17 +477,18 @@ commandMacroError :: CommandCallback
commandMacroError ctx [msg] = commandMacroError ctx [msg] =
pure $ case msg of pure $ case msg of
XObj (Str smsg) _ _ -> evalError ctx smsg (xobjInfo msg) 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 :: CommandCallback
commandMacroLog ctx msgs = do commandMacroLog ctx msgs = do
liftIO (mapM_ (putStr . logify) msgs) liftIO (mapM_ (putStr . logify) msgs)
liftIO (putStr "\n") liftIO (putStr "\n")
pure (ctx, dynamicNil) pure (ctx, dynamicNil)
where logify m = where
case m of logify m =
XObj (Str msg) _ _ -> msg case m of
x -> pretty x XObj (Str msg) _ _ -> msg
x -> pretty x
commandEq :: CommandCallback commandEq :: CommandCallback
commandEq ctx [a, b] = 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') Left (a', b') -> evalError ctx ("Can't compare " ++ pretty a' ++ " with " ++ pretty b') (xobjInfo a')
Right b' -> (ctx, Right (boolToXObj b')) Right b' -> (ctx, Right (boolToXObj b'))
where where
cmp (XObj (Num aTy aNum) _ _, XObj (Num bTy bNum) _ _) | aTy == bTy = cmp (XObj (Num aTy aNum) _ _, XObj (Num bTy bNum) _ _)
Right $ aNum == bNum | aTy == bTy =
Right $ aNum == bNum
cmp (XObj (Str sa) _ _, XObj (Str sb) _ _) = Right $ sa == sb cmp (XObj (Str sa) _ _, XObj (Str sb) _ _) = Right $ sa == sb
cmp (XObj (Chr ca) _ _, XObj (Chr cb) _ _) = Right $ ca == cb cmp (XObj (Chr ca) _ _, XObj (Chr cb) _ _) = Right $ ca == cb
cmp (XObj (Sym sa _) _ _, XObj (Sym sb _) _ _) = Right $ sa == sb 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 []) _ _, XObj (Lst []) _ _) = Right True
cmp (XObj (Lst elemsA) _ _, XObj (Lst elemsB) _ _) = cmp (XObj (Lst elemsA) _ _, XObj (Lst elemsB) _ _) =
if length elemsA == length elemsB if length elemsA == length elemsB
then foldr cmp' (Right True) (zip elemsA elemsB) then foldr cmp' (Right True) (zip elemsA elemsB)
else Right False else Right False
cmp (XObj (Arr []) _ _, XObj (Arr []) _ _) = Right True cmp (XObj (Arr []) _ _, XObj (Arr []) _ _) = Right True
cmp (XObj (Arr elemsA) _ _, XObj (Arr elemsB) _ _) = cmp (XObj (Arr elemsA) _ _, XObj (Arr elemsB) _ _) =
if length elemsA == length elemsB if length elemsA == length elemsB
then foldr cmp' (Right True) (zip elemsA elemsB) then foldr cmp' (Right True) (zip elemsA elemsB)
else Right False else Right False
cmp invalid = Left invalid cmp invalid = Left invalid
cmp' _ invalid@(Left _) = invalid cmp' _ invalid@(Left _) = invalid
cmp' _ (Right False) = Right False 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 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) commandComp _ opname ctx [a, b] = pure $ evalError ctx ("Can't compare (" ++ opname ++ ") " ++ pretty a ++ " with " ++ pretty b) (xobjInfo a)
commandLt :: CommandCallback commandLt :: CommandCallback
commandLt = commandComp (<) "<" commandLt = commandComp (<) "<"
@ -501,8 +549,8 @@ commandCharAt ctx [a, b] =
pure $ case (a, b) of pure $ case (a, b) of
(XObj (Str s) _ _, XObj (Num IntTy (Integral i)) _ _) -> (XObj (Str s) _ _, XObj (Num IntTy (Integral i)) _ _) ->
if length s > i if length s > i
then (ctx, Right (XObj (Chr (s !! i)) (Just dummyInfo) (Just IntTy))) 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) 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) _ -> evalError ctx ("Can't call char-at with " ++ pretty a ++ " and " ++ pretty b) (xobjInfo a)
commandIndexOf :: CommandCallback commandIndexOf :: CommandCallback
@ -511,7 +559,8 @@ commandIndexOf ctx [a, b] =
(XObj (Str s) _ _, XObj (Chr c) _ _) -> (XObj (Str s) _ _, XObj (Chr c) _ _) ->
(ctx, Right (XObj (Num IntTy (Integral (getIdx c s))) (Just dummyInfo) (Just IntTy))) (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) _ -> 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 :: CommandCallback
commandSubstring ctx [a, b, c] = commandSubstring ctx [a, b, c] =
@ -539,7 +588,8 @@ commandStringConcat ctx [a] =
commandStringSplitOn :: CommandCallback commandStringSplitOn :: CommandCallback
commandStringSplitOn ctx [XObj (Str sep) _ _, XObj (Str s) _ _] = commandStringSplitOn ctx [XObj (Str sep) _ _, XObj (Str s) _ _] =
pure $ (ctx, Right (XObj (Arr (xstr <$> splitOn sep s)) (Just dummyInfo) Nothing)) 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] = commandStringSplitOn ctx [sep, s] =
pure $ evalError ctx ("Can't call split-on with " ++ pretty sep ++ ", " ++ pretty s) (xobjInfo sep) 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 $ (ctx, Right (XObj (Str abs) (Just dummyInfo) (Just StringTy)))
_ -> pure $ evalError ctx ("Can't call `absolute` with " ++ pretty a) (xobjInfo a) _ -> pure $ evalError ctx ("Can't call `absolute` with " ++ pretty a) (xobjInfo a)
commandArith :: (Number -> Number -> Number) -> String -> CommandCallback commandArith :: (Number -> Number -> Number) -> String -> CommandCallback
commandArith op _ ctx [XObj (Num aTy aNum) _ _, XObj (Num bTy bNum) _ _] | aTy == bTy = commandArith op _ ctx [XObj (Num aTy aNum) _ _, XObj (Num bTy bNum) _ _]
pure $ (ctx, Right (XObj (Num aTy (op aNum bNum)) (Just dummyInfo) (Just aTy))) | 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) commandArith _ opname ctx [a, b] = pure $ evalError ctx ("Can't call " ++ opname ++ " with " ++ pretty a ++ " and " ++ pretty b) (xobjInfo a)
commandPlus :: CommandCallback commandPlus :: CommandCallback
@ -617,13 +667,14 @@ commandMul = commandArith (*) "*"
commandStr :: CommandCallback commandStr :: CommandCallback
commandStr ctx xs = commandStr ctx xs =
pure (ctx, Right (XObj (Str (join (map f xs))) (Just dummyInfo) (Just StringTy))) 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
where f (XObj (Str s) _ _) = s -- TODO: Is there a better function to call here than some exceptions + 'pretty'?
f (XObj (Sym path _) _ _) = show path f (XObj (Str s) _ _) = s
f x = escape $ pretty x f (XObj (Sym path _) _ _) = show path
escape [] = [] f x = escape $ pretty x
escape ('\\':y) = "\\\\" ++ escape y escape [] = []
escape (x:y) = x : escape y escape ('\\' : y) = "\\\\" ++ escape y
escape (x : y) = x : escape y
commandNot :: CommandCallback commandNot :: CommandCallback
commandNot ctx [x] = commandNot ctx [x] =
@ -635,10 +686,10 @@ commandReadFile :: CommandCallback
commandReadFile ctx [filename] = commandReadFile ctx [filename] =
case filename of case filename of
XObj (Str fname) _ _ -> do XObj (Str fname) _ _ -> do
exceptional <- liftIO ((try $ slurp fname) :: (IO (Either IOException String))) exceptional <- liftIO ((try $ slurp fname) :: (IO (Either IOException String)))
pure $ case exceptional of pure $ case exceptional of
Right contents -> (ctx, Right (XObj (Str contents) (Just dummyInfo) (Just StringTy))) 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)) 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)) _ -> pure (evalError ctx ("The argument to `read-file` must be a string, I got `" ++ pretty filename ++ "`") (xobjInfo filename))
commandWriteFile :: CommandCallback commandWriteFile :: CommandCallback
@ -647,8 +698,8 @@ commandWriteFile ctx [filename, contents] =
XObj (Str fname) _ _ -> XObj (Str fname) _ _ ->
case contents of case contents of
XObj (Str s) _ _ -> do XObj (Str s) _ _ -> do
exceptional <- liftIO ((try $ writeFile fname s) :: (IO (Either IOException ()))) exceptional <- liftIO ((try $ writeFile fname s) :: (IO (Either IOException ())))
pure $ case exceptional of pure $ case exceptional of
Right () -> (ctx, dynamicNil) Right () -> (ctx, dynamicNil)
Left _ -> evalError ctx ("Cannot write to argument to `" ++ fname ++ "`, an argument to `write-file`") (xobjInfo filename) 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)) _ -> 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 :: CommandCallback
commandHostBitWidth ctx [] = commandHostBitWidth ctx [] =
let bitSize = Integral (finiteBitSize (undefined :: Int)) 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 :: CommandCallback
commandSaveDocsInternal ctx [modulePath] = do commandSaveDocsInternal ctx [modulePath] = do
let globalEnv = contextGlobalEnv ctx let globalEnv = contextGlobalEnv ctx
case modulePath of case modulePath of
XObj (Lst xobjs) _ _ -> XObj (Lst xobjs) _ _ ->
case mapM unwrapSymPathXObj xobjs of case mapM unwrapSymPathXObj xobjs of
Left err -> pure (evalError ctx err (xobjInfo modulePath)) Left err -> pure (evalError ctx err (xobjInfo modulePath))
Right okPaths -> Right okPaths ->
case mapM (getEnvironmentBinderForDocumentation ctx globalEnv) okPaths of case mapM (getEnvironmentBinderForDocumentation ctx globalEnv) okPaths of
Left err -> pure (evalError ctx err (xobjInfo modulePath)) Left err -> pure (evalError ctx err (xobjInfo modulePath))
Right okEnvBinders -> saveDocs ctx (zip okPaths okEnvBinders) Right okEnvBinders -> saveDocs ctx (zip okPaths okEnvBinders)
x -> x ->
pure (evalError ctx ("Invalid arg to save-docs-internal (expected list of symbols): " ++ pretty x) (xobjInfo modulePath)) 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 where
getEnvironmentBinderForDocumentation _ env path = getEnvironmentBinderForDocumentation :: Context -> Env -> SymPath -> Either String Binder
case lookupInEnv path env of getEnvironmentBinderForDocumentation _ env path =
Just (_, foundBinder@(Binder _ (XObj (Mod _) _ _))) -> case lookupInEnv path env of
Right foundBinder Just (_, foundBinder@(Binder _ (XObj (Mod _) _ _))) ->
Just (_, Binder _ x) -> Right foundBinder
Left ("I can’t generate documentation for `" ++ pretty x ++ "` because it isn’t a module") Just (_, Binder _ x) ->
Nothing -> Left ("I can’t generate documentation for `" ++ pretty x ++ "` because it isn’t a module")
Left ("I can’t find the module `" ++ show path ++ "`") Nothing ->
Left ("I can’t find the module `" ++ show path ++ "`")
saveDocs :: Context -> [(SymPath, Binder)] -> IO (Context, Either a XObj) saveDocs :: Context -> [(SymPath, Binder)] -> IO (Context, Either a XObj)
saveDocs ctx pathsAndEnvBinders = do saveDocs ctx pathsAndEnvBinders = do
liftIO (saveDocsForEnvs (contextProj ctx) pathsAndEnvBinders) liftIO (saveDocsForEnvs (contextProj ctx) pathsAndEnvBinders)
pure (ctx, dynamicNil) pure (ctx, dynamicNil)
commandSexpression :: CommandCallback commandSexpression :: CommandCallback
commandSexpression ctx [xobj, (XObj (Bol b) _ _)] = commandSexpression ctx [xobj, (XObj (Bol b) _ _)] =
@ -698,44 +750,54 @@ commandSexpression ctx xobj =
commandSexpressionInternal :: Context -> [XObj] -> Bool -> IO (Context, Either EvalError XObj) commandSexpressionInternal :: Context -> [XObj] -> Bool -> IO (Context, Either EvalError XObj)
commandSexpressionInternal ctx [xobj] bol = commandSexpressionInternal ctx [xobj] bol =
let tyEnv = getTypeEnv $ contextTypeEnv ctx let tyEnv = getTypeEnv $ contextTypeEnv ctx
in case xobj of in case xobj of
(XObj (Lst [inter@(XObj (Interface ty _) _ _), path]) i t) -> (XObj (Lst [inter@(XObj (Interface ty _) _ _), path]) i t) ->
pure (ctx, Right (XObj (Lst [(toSymbols inter), path, (reify ty)]) i t)) pure (ctx, Right (XObj (Lst [(toSymbols inter), path, (reify ty)]) i t))
(XObj (Lst forms) i t) -> (XObj (Lst forms) i t) ->
pure (ctx, Right (XObj (Lst (map toSymbols forms)) i t)) pure (ctx, Right (XObj (Lst (map toSymbols forms)) i t))
mdl@(XObj (Mod e) _ _) -> mdl@(XObj (Mod e) _ _) ->
if bol if bol
then getMod then getMod
else else case lookupInEnv (SymPath [] (fromMaybe "" (envModuleName e))) tyEnv of
case lookupInEnv (SymPath [] (fromMaybe "" (envModuleName e))) tyEnv of Just (_, Binder _ (XObj (Lst forms) i t)) ->
Just (_, Binder _ (XObj (Lst forms) i t)) -> pure (ctx, Right (XObj (Lst (map toSymbols forms)) i t))
pure (ctx, Right (XObj (Lst (map toSymbols forms)) i t)) Just (_, Binder _ xobj') ->
Just (_, Binder _ xobj') -> pure (ctx, Right (toSymbols xobj'))
pure (ctx, Right (toSymbols xobj')) Nothing ->
Nothing -> getMod
getMod where
where getMod = getMod =
case (toSymbols mdl) of case (toSymbols mdl) of
x@(XObj (Lst _) _ _) -> x@(XObj (Lst _) _ _) ->
bindingSyms e (ctx, Right x) bindingSyms e (ctx, Right x)
where bindingSyms env start = where
(mapM (\x -> commandSexpression ctx [x]) $ bindingSyms env start =
map snd $ ( mapM (\x -> commandSexpression ctx [x])
Map.toList $ Map.map binderXObj (envBindings env)) $ map snd
>>= pure . foldl combine start $ Map.toList
combine (c, (Right (XObj (Lst xs) i t))) (_ , (Right y@(XObj (Lst _) _ _))) = $ Map.map binderXObj (envBindings env)
(c, Right (XObj (Lst (xs ++ [y])) i t)) )
combine _ (c, (Left err)) = >>= pure . foldl combine start
(c, Left err) combine (c, (Right (XObj (Lst xs) i t))) (_, (Right y@(XObj (Lst _) _ _))) =
combine (c, Left err) _ = (c, Right (XObj (Lst (xs ++ [y])) i t))
(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) 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 -> XObj
toSymbols (XObj (Mod e) i t) = toSymbols (XObj (Mod e) i t) =
(XObj (Lst [XObj (Sym (SymPath [] "defmodule") Symbol) i t, ( XObj
XObj (Sym (SymPath [] (fromMaybe "" (envModuleName e))) Symbol) i t]) i t) ( 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 (Defn _) i t) = (XObj (Sym (SymPath [] "defn") Symbol) i t)
toSymbols (XObj Def i t) = (XObj (Sym (SymPath [] "def") 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) 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, module Constraints
Constraint(..), ( solve,
ConstraintOrder(..), Constraint (..),
UnificationFailure(..), ConstraintOrder (..),
recursiveLookup, UnificationFailure (..),
debugSolveOne, -- exported to avoid warning about unused function (should be another way...) recursiveLookup,
debugResolveFully -- exported to avoid warning about unused function debugSolveOne, -- exported to avoid warning about unused function (should be another way...)
) where debugResolveFully, -- exported to avoid warning about unused function
)
where
import Control.Monad
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.Set as Set import qualified Data.Set as Set
import Control.Monad
import Debug.Trace import Debug.Trace
import Obj import Obj
import Types import Types
data ConstraintOrder = OrdNo data ConstraintOrder
| OrdFunc = OrdNo
| OrdStruct | OrdFunc
| OrdPtr | OrdStruct
| OrdRef | OrdPtr
| OrdDeref | OrdRef
| OrdFuncAppRet | OrdDeref
| OrdArrHead | OrdFuncAppRet
| OrdArg | OrdArrHead
| OrdCapture | OrdArg
| OrdDefnBody | OrdCapture
| OrdDefExpr | OrdDefnBody
| OrdLetBind | OrdDefExpr
| OrdLetBody | OrdLetBind
| OrdIfCondition | OrdLetBody
| OrdIfReturn | OrdIfCondition
| OrdIfWhole | OrdIfReturn
| OrdWhileBody | OrdIfWhole
| OrdWhileCondition | OrdWhileBody
| OrdDoReturn | OrdWhileCondition
| OrdDoStatement | OrdDoReturn
| OrdSetBang | OrdDoStatement
| OrdThe | OrdSetBang
| OrdAnd | OrdThe
| OrdOr | OrdAnd
| OrdFuncAppVarTy | OrdOr
| OrdFuncAppArg | OrdFuncAppVarTy
| OrdArrBetween | OrdFuncAppArg
| OrdMultiSym | OrdArrBetween
| OrdInterfaceSym | OrdMultiSym
| OrdInterfaceImpl | OrdInterfaceSym
| OrdSignatureAnnotation | OrdInterfaceImpl
deriving (Show, Ord, Eq) | 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 instance Ord Constraint where
compare (Constraint _ _ _ _ _ a) (Constraint _ _ _ _ _ b) = compare a b compare (Constraint _ _ _ _ _ a) (Constraint _ _ _ _ _ b) = compare a b
data UnificationFailure = UnificationFailure { unificationFailure ::Constraint data UnificationFailure
, unificationMappings :: TypeMappings = UnificationFailure
} { unificationFailure :: Constraint,
| Holes [(String, Ty)] unificationMappings :: TypeMappings
deriving (Eq, Show) }
| Holes [(String, Ty)]
deriving (Eq, Show)
instance Show Constraint where 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 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) -- Finds the symbol with the "lowest name" (first in alphabetical order)
recursiveLookup :: TypeMappings -> String -> Maybe Ty recursiveLookup :: TypeMappings -> String -> Maybe Ty
recursiveLookup mappings name = innerLookup name [] recursiveLookup mappings name = innerLookup name []
where innerLookup :: String -> [Ty] -> Maybe Ty where
innerLookup k visited = innerLookup :: String -> [Ty] -> Maybe Ty
case Map.lookup k mappings of innerLookup k visited =
Just exists -> case exists of case Map.lookup k mappings of
VarTy v -> if exists `elem` visited Just exists -> case exists of
then stop VarTy v ->
else innerLookup v (exists : visited) if exists `elem` visited
actualType -> Just actualType then stop
where else innerLookup v (exists : visited)
stop = Just (minimum (exists : visited)) actualType -> Just actualType
Nothing -> Nothing where
stop = Just (minimum (exists : visited))
Nothing -> Nothing
-- | This is the entry-point function that takes a list of constraints -- | This is the entry-point function that takes a list of constraints
-- (for example [t0 == Int, t1 == t0, t1 == t2]) -- (for example [t0 == Int, t1 == t0, t1 == t2])
-- and creates a dictionary of mappings for the type variables -- and creates a dictionary of mappings for the type variables
-- (for example t0 => Int, t1 => Int, t2 => Int). -- (for example t0 => Int, t1 => Int, t2 => Int).
solve :: [Constraint] -> Either UnificationFailure TypeMappings solve :: [Constraint] -> Either UnificationFailure TypeMappings
solve constraints = do naiveMappings <- foldM solveOne Map.empty constraints solve constraints = do
fullyResolved <- foldM resolveFully naiveMappings (map fst (Map.toList naiveMappings)) naiveMappings <- foldM solveOne Map.empty constraints
checkForHoles fullyResolved fullyResolved <- foldM resolveFully naiveMappings (map fst (Map.toList naiveMappings))
checkForHoles fullyResolved
checkForHoles :: TypeMappings -> Either UnificationFailure TypeMappings checkForHoles :: TypeMappings -> Either UnificationFailure TypeMappings
checkForHoles mappings = case filter isTypeHole (Map.toList mappings) of checkForHoles mappings = case filter isTypeHole (Map.toList mappings) of
@ -100,78 +107,80 @@ solveOne :: TypeMappings -> Constraint -> Either UnificationFailure TypeMappings
solveOne = solveOneInternal solveOne = solveOneInternal
debugSolveOne :: TypeMappings -> Constraint -> Either UnificationFailure TypeMappings debugSolveOne :: TypeMappings -> Constraint -> Either UnificationFailure TypeMappings
debugSolveOne mappings constraint = let m' = solveOneInternal mappings constraint debugSolveOne mappings constraint =
in trace ("" ++ show constraint ++ ", MAPPINGS: " ++ show m') let m' = solveOneInternal mappings constraint
m' in trace
("" ++ show constraint ++ ", MAPPINGS: " ++ show m')
m'
solveOneInternal :: TypeMappings -> Constraint -> Either UnificationFailure TypeMappings solveOneInternal :: TypeMappings -> Constraint -> Either UnificationFailure TypeMappings
solveOneInternal mappings constraint = solveOneInternal mappings constraint =
case constraint of --trace ("SOLVE " ++ show constraint) constraint of case constraint of --trace ("SOLVE " ++ show constraint) constraint of
-- Two type variables -- Two type variables
Constraint aTy@(VarTy aName) bTy@(VarTy bName) _ _ _ _ -> Constraint aTy@(VarTy aName) bTy@(VarTy bName) _ _ _ _ ->
if aTy == bTy if aTy == bTy
then Right mappings then Right mappings
else do m' <- checkForConflict mappings constraint aName bTy else do
checkForConflict m' constraint bName aTy m' <- checkForConflict mappings constraint aName bTy
checkForConflict m' constraint bName aTy
-- One type variable -- One type variable
Constraint (VarTy aName) bTy _ _ _ _ -> checkForConflict mappings constraint aName bTy Constraint (VarTy aName) bTy _ _ _ _ -> checkForConflict mappings constraint aName bTy
Constraint aTy (VarTy bName) _ _ _ _ -> checkForConflict mappings constraint bName aTy Constraint aTy (VarTy bName) _ _ _ _ -> checkForConflict mappings constraint bName aTy
-- Struct types -- Struct types
Constraint (StructTy nameA varsA) (StructTy nameB varsB) _ _ _ _ -> Constraint (StructTy nameA varsA) (StructTy nameB varsB) _ _ _ _ ->
let (Constraint _ _ i1 i2 ctx ord) = constraint let (Constraint _ _ i1 i2 ctx ord) = constraint
in case solveOneInternal mappings (Constraint nameA nameB i1 i2 ctx ord) of in case solveOneInternal mappings (Constraint nameA nameB i1 i2 ctx ord) of
Left err -> Left err Left err -> Left err
Right ok -> foldM (\m (aa, bb) -> solveOneInternal m (Constraint aa bb i1 i2 ctx ord)) ok (zip varsA varsB) Right ok -> foldM (\m (aa, bb) -> solveOneInternal m (Constraint aa bb i1 i2 ctx ord)) ok (zip varsA varsB)
-- Func types -- Func types
Constraint (FuncTy argsA retA ltA) (FuncTy argsB retB ltB) _ _ _ _ -> Constraint (FuncTy argsA retA ltA) (FuncTy argsB retB ltB) _ _ _ _ ->
if length argsA == length argsB if length argsA == length argsB
then let (Constraint _ _ i1 i2 ctx ord) = constraint then
res = foldM (\m (aa, bb) -> solveOneInternal m (Constraint aa bb i1 i2 ctx ord)) mappings (zip (retA : argsA) let (Constraint _ _ i1 i2 ctx ord) = constraint
(retB : argsB)) res =
in case res of foldM
Right ok -> solveOneInternal ok (Constraint ltA ltB i1 i2 ctx ord) (\m (aa, bb) -> solveOneInternal m (Constraint aa bb i1 i2 ctx ord))
Left err -> Left err mappings
else Left (UnificationFailure constraint 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 -- Pointer types
Constraint (PointerTy a) (PointerTy b) _ _ _ _ -> Constraint (PointerTy a) (PointerTy b) _ _ _ _ ->
let (Constraint _ _ i1 i2 ctx ord) = constraint 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 -- 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!!! -- 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) _ _ _ _ -> Constraint (RefTy a ltA) (RefTy b ltB) _ _ _ _ ->
let (Constraint _ _ i1 i2 ctx ord) = constraint 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 Left err -> Left err
Right ok -> solveOneInternal ok (Constraint ltA ltB i1 i2 ctx ord) Right ok -> solveOneInternal ok (Constraint ltA ltB i1 i2 ctx ord)
-- As a special case, allow Refs to stand for higher-order polymorphic -- As a special case, allow Refs to stand for higher-order polymorphic
-- structs (f a b) ~ (Ref a b) -- structs (f a b) ~ (Ref a b)
Constraint (StructTy v@(VarTy _) args) (RefTy b ltB) _ _ _ _ -> Constraint (StructTy v@(VarTy _) args) (RefTy b ltB) _ _ _ _ ->
let (Constraint _ _ i1 i2 ctx ord) = constraint 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 Left err -> Left err
Right ok -> foldM (\m (aa, bb) -> solveOneInternal m (Constraint aa bb i1 i2 ctx ord)) ok (zip args [b, ltB]) 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 -- TODO: The reverse argument order is necessary here since interface code
-- uses the opposite order of most other solving code (abstract, concrete -- uses the opposite order of most other solving code (abstract, concrete
-- vs. concrete, abstract)--we should bring the interface code into -- vs. concrete, abstract)--we should bring the interface code into
-- compliance with this to obviate this stanza -- compliance with this to obviate this stanza
Constraint (RefTy b ltB) (StructTy v@(VarTy _) args) _ _ _ _ -> Constraint (RefTy b ltB) (StructTy v@(VarTy _) args) _ _ _ _ ->
let (Constraint _ _ i1 i2 ctx ord) = constraint 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 Left err -> Left err
Right ok -> foldM (\m (aa, bb) -> solveOneInternal m (Constraint aa bb i1 i2 ctx ord)) ok (zip args [b, ltB]) Right ok -> foldM (\m (aa, bb) -> solveOneInternal m (Constraint aa bb i1 i2 ctx ord)) ok (zip args [b, ltB])
-- Else -- Else
Constraint aTy bTy _ _ _ _ -> Constraint aTy bTy _ _ _ _ ->
if aTy == bTy if aTy == bTy
then Right mappings then Right mappings
else Left (UnificationFailure constraint mappings) else Left (UnificationFailure constraint mappings)
mkConstraint :: ConstraintOrder -> XObj -> XObj -> XObj -> Ty -> Ty -> Constraint mkConstraint :: ConstraintOrder -> XObj -> XObj -> XObj -> Ty -> Ty -> Constraint
mkConstraint order xobj1 xobj2 ctx t1 t2 = Constraint t1 t2 xobj1 xobj2 ctx order 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 checkConflictInternal mappings constraint name otherTy
checkForConflict mappings constraint name otherTy = checkForConflict mappings constraint name otherTy =
if doesTypeContainTyVarWithName name otherTy if doesTypeContainTyVarWithName name otherTy
then Left (UnificationFailure constraint mappings) then Left (UnificationFailure constraint mappings)
else checkConflictInternal mappings constraint name otherTy else checkConflictInternal mappings constraint name otherTy
checkConflictInternal :: TypeMappings -> Constraint -> String -> Ty -> Either UnificationFailure TypeMappings checkConflictInternal :: TypeMappings -> Constraint -> String -> Ty -> Either UnificationFailure TypeMappings
checkConflictInternal mappings constraint name otherTy = checkConflictInternal mappings constraint name otherTy =
let (Constraint _ _ xobj1 xobj2 ctx _) = constraint let (Constraint _ _ xobj1 xobj2 ctx _) = constraint
found = recursiveLookup mappings name 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 (VarTy _) -> ok
Just (StructTy (VarTy _) structTyVars) -> Just (StructTy (VarTy _) structTyVars) ->
case otherTy of case otherTy of
@ -209,10 +218,11 @@ checkConflictInternal mappings constraint name otherTy =
Just (FuncTy argTys retTy lifetimeTy) -> Just (FuncTy argTys retTy lifetimeTy) ->
case otherTy of case otherTy of
FuncTy otherArgTys otherRetTy otherLifetimeTy -> FuncTy otherArgTys otherRetTy otherLifetimeTy ->
do m <- foldM solveOneInternal mappings (zipWith (mkConstraint OrdFunc xobj1 xobj2 ctx) argTys otherArgTys) do
case solveOneInternal m (mkConstraint OrdFunc xobj1 xobj2 ctx retTy otherRetTy) of m <- foldM solveOneInternal mappings (zipWith (mkConstraint OrdFunc xobj1 xobj2 ctx) argTys otherArgTys)
Right _ -> solveOneInternal m (mkConstraint OrdFunc xobj1 xobj2 ctx lifetimeTy otherLifetimeTy) case solveOneInternal m (mkConstraint OrdFunc xobj1 xobj2 ctx retTy otherRetTy) of
Left err -> Left err Right _ -> solveOneInternal m (mkConstraint OrdFunc xobj1 xobj2 ctx lifetimeTy otherLifetimeTy)
Left err -> Left err
VarTy _ -> Right mappings VarTy _ -> Right mappings
_ -> Left (UnificationFailure constraint mappings) _ -> Left (UnificationFailure constraint mappings)
Just (PointerTy innerTy) -> Just (PointerTy innerTy) ->
@ -229,46 +239,48 @@ checkConflictInternal mappings constraint name otherTy =
VarTy _ -> Right mappings VarTy _ -> Right mappings
_ -> Left (UnificationFailure constraint mappings) _ -> Left (UnificationFailure constraint mappings)
Just foundNonVar -> case otherTy of Just foundNonVar -> case otherTy of
(VarTy v) -> case recursiveLookup mappings v of (VarTy v) -> case recursiveLookup mappings v of
Just (VarTy _) -> Right mappings Just (VarTy _) -> Right mappings
Just otherNonVar -> if foundNonVar == otherNonVar Just otherNonVar ->
then Right mappings if foundNonVar == otherNonVar
else Left (UnificationFailure constraint mappings) then Right mappings
Nothing -> Right mappings else Left (UnificationFailure constraint mappings)
_ -> if otherTy == foundNonVar Nothing -> Right mappings
then ok _ ->
else Left (UnificationFailure constraint mappings) if otherTy == foundNonVar
then ok
else Left (UnificationFailure constraint mappings)
-- Not found, no risk for conflict: -- Not found, no risk for conflict:
Nothing -> ok Nothing -> ok
where where
ok = Right (Map.insert name otherTy mappings) ok = Right (Map.insert name otherTy mappings)
debugResolveFully :: TypeMappings -> String -> Either UnificationFailure TypeMappings debugResolveFully :: TypeMappings -> String -> Either UnificationFailure TypeMappings
debugResolveFully mappings var = trace ("Mappings: " ++ show mappings ++ ", will resolve " ++ show var) (resolveFully mappings var) debugResolveFully mappings var = trace ("Mappings: " ++ show mappings ++ ", will resolve " ++ show var) (resolveFully mappings var)
resolveFully :: TypeMappings -> String -> Either UnificationFailure TypeMappings resolveFully :: TypeMappings -> String -> Either UnificationFailure TypeMappings
resolveFully mappings varName = Right (Map.insert varName (fullResolve (VarTy varName)) mappings) resolveFully mappings varName = Right (Map.insert varName (fullResolve (VarTy varName)) mappings)
where
where fullResolve :: Ty -> Ty fullResolve :: Ty -> Ty
fullResolve x@(VarTy var) = fullResolve x@(VarTy var) =
case recursiveLookup mappings var of case recursiveLookup mappings var of
Just (StructTy name varTys) -> StructTy name (map (fullLookup Set.empty) varTys) 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 (FuncTy argTys retTy ltTy) -> FuncTy (map (fullLookup Set.empty) argTys) (fullLookup Set.empty retTy) (fullLookup Set.empty ltTy)
Just found -> found Just found -> found
Nothing -> x -- still not found, must be a generic variable Nothing -> x -- still not found, must be a generic variable
fullResolve x = x fullResolve x = x
fullLookup :: Set.Set Ty -> Ty -> Ty
fullLookup :: Set.Set Ty -> Ty -> Ty fullLookup visited vv@(VarTy v) =
fullLookup visited vv@(VarTy v) = case recursiveLookup mappings v of
case recursiveLookup mappings v of Just found ->
Just found -> if found == vv || Set.member found visited if found == vv || Set.member found visited
then found then found
else fullLookup (Set.insert found visited) found else fullLookup (Set.insert found visited) found
Nothing -> vv-- compilerError ("In full lookup: Can't find " ++ v ++ " in mappings: " ++ show mappings) Nothing -> vv -- compilerError ("In full lookup: Can't find " ++ v ++ " in mappings: " ++ show mappings)
fullLookup visited structTy@(StructTy name vs) = fullLookup visited structTy@(StructTy name vs) =
let newVisited = Set.insert structTy visited let newVisited = Set.insert structTy visited
in StructTy name (map (fullLookup newVisited) vs) in StructTy name (map (fullLookup newVisited) vs)
fullLookup visited funcTy@(FuncTy argTys retTy ltTy) = fullLookup visited funcTy@(FuncTy argTys retTy ltTy) =
let newVisited = Set.insert funcTy visited let newVisited = Set.insert funcTy visited
in FuncTy (map (fullLookup newVisited) argTys) (fullLookup newVisited retTy) (fullLookup newVisited ltTy) in FuncTy (map (fullLookup newVisited) argTys) (fullLookup newVisited retTy) (fullLookup newVisited ltTy)
fullLookup _ x = x fullLookup _ x = x

664
src/Deftype.hs
View File

@ -1,25 +1,30 @@
{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE MultiWayIf #-}
module Deftype (moduleForDeftype, bindingsForRegisteredType, memberArg) where module Deftype
( moduleForDeftype,
bindingsForRegisteredType,
memberArg,
)
where
import Concretize
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Maybe import Data.Maybe
import Infer
import Info
import Lookup
import Obj import Obj
import StructUtils
import Template
import ToTemplate
import TypeError
import Types import Types
import TypesToC import TypesToC
import Util import Util
import Template
import ToTemplate
import Infer
import Concretize
import Lookup
import StructUtils
import TypeError
import Validate import Validate
import Info
{-# ANN module "HLint: ignore Reduce duplication" #-} {-# ANN module "HLint: ignore Reduce duplication" #-}
-- | This function creates a "Type Module" with the same name as the type being defined. -- | This function creates a "Type Module" with the same name as the type being defined.
-- A type module provides a namespace for all the functions that area automatically -- A type module provides a namespace for all the functions that area automatically
-- generated by a deftype. -- generated by a deftype.
@ -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'. -- The variable 'insidePath' is the path used for all member functions inside the 'typeModule'.
-- For example (module Vec2 [x Float]) creates bindings like Vec2.create, Vec2.x, etc. -- For example (module Vec2 [x Float]) creates bindings like Vec2.create, Vec2.x, etc.
insidePath = pathStrings ++ [typeModuleName] insidePath = pathStrings ++ [typeModuleName]
in do validateMemberCases typeEnv typeVariables rest in do
validateMemberCases typeEnv typeVariables rest
let structTy = StructTy (ConcreteNameTy typeName) typeVariables let structTy = StructTy (ConcreteNameTy typeName) typeVariables
(okMembers, membersDeps) <- templatesForMembers typeEnv env insidePath structTy rest (okMembers, membersDeps) <- templatesForMembers typeEnv env insidePath structTy rest
okInit <- binderForInit insidePath structTy rest okInit <- binderForInit insidePath structTy rest
@ -38,7 +44,7 @@ moduleForDeftype innerEnv typeEnv env pathStrings typeName typeVariables rest i
(okPrn, _) <- binderForStrOrPrn typeEnv env insidePath structTy rest "prn" (okPrn, _) <- binderForStrOrPrn typeEnv env insidePath structTy rest "prn"
(okDelete, deleteDeps) <- binderForDelete typeEnv env insidePath structTy rest (okDelete, deleteDeps) <- binderForDelete typeEnv env insidePath structTy rest
(okCopy, copyDeps) <- binderForCopy typeEnv env insidePath structTy rest (okCopy, copyDeps) <- binderForCopy typeEnv env insidePath structTy rest
let funcs = okInit : okStr : okPrn : okDelete : okCopy : okMembers let funcs = okInit : okStr : okPrn : okDelete : okCopy : okMembers
moduleEnvWithBindings = addListOfBindings typeModuleEnv funcs moduleEnvWithBindings = addListOfBindings typeModuleEnv funcs
typeModuleXObj = XObj (Mod moduleEnvWithBindings) i (Just ModuleTy) typeModuleXObj = XObj (Mod moduleEnvWithBindings) i (Just ModuleTy)
deps = deleteDeps ++ membersDeps ++ copyDeps ++ strDeps deps = deleteDeps ++ membersDeps ++ copyDeps ++ strDeps
@ -52,7 +58,8 @@ bindingsForRegisteredType typeEnv env pathStrings typeName rest i existingEnv =
let typeModuleName = typeName let typeModuleName = typeName
typeModuleEnv = fromMaybe (Env (Map.fromList []) (Just env) (Just typeModuleName) [] ExternalEnv 0) existingEnv typeModuleEnv = fromMaybe (Env (Map.fromList []) (Just env) (Just typeModuleName) [] ExternalEnv 0) existingEnv
insidePath = pathStrings ++ [typeModuleName] insidePath = pathStrings ++ [typeModuleName]
in do validateMemberCases typeEnv [] rest in do
validateMemberCases typeEnv [] rest
let structTy = StructTy (ConcreteNameTy typeName) [] let structTy = StructTy (ConcreteNameTy typeName) []
(binders, deps) <- templatesForMembers typeEnv env insidePath structTy rest (binders, deps) <- templatesForMembers typeEnv env insidePath structTy rest
okInit <- binderForInit insidePath structTy rest okInit <- binderForInit insidePath structTy rest
@ -62,13 +69,11 @@ bindingsForRegisteredType typeEnv env pathStrings typeName rest i existingEnv =
typeModuleXObj = XObj (Mod moduleEnvWithBindings) i (Just ModuleTy) typeModuleXObj = XObj (Mod moduleEnvWithBindings) i (Just ModuleTy)
pure (typeModuleName, typeModuleXObj, deps ++ strDeps) pure (typeModuleName, typeModuleXObj, deps ++ strDeps)
-- | Generate all the templates for ALL the member variables in a deftype declaration. -- | Generate all the templates for ALL the member variables in a deftype declaration.
templatesForMembers :: TypeEnv -> Env -> [String] -> Ty -> [XObj] -> Either TypeError ([(String, Binder)], [XObj]) templatesForMembers :: TypeEnv -> Env -> [String] -> Ty -> [XObj] -> Either TypeError ([(String, Binder)], [XObj])
templatesForMembers typeEnv env insidePath structTy [XObj (Arr membersXobjs) _ _] = templatesForMembers typeEnv env insidePath structTy [XObj (Arr membersXobjs) _ _] =
let bindersAndDeps = concatMap (templatesForSingleMember typeEnv env insidePath structTy) (pairwise 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)." templatesForMembers _ _ _ _ _ = error "Shouldn't reach this case (invalid type definition)."
-- | Generate the templates for a single member in a deftype declaration. -- | 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 -- Instead, members of type Unit are executed for their side effects and silently omitted
-- from the produced C structs. -- from the produced C structs.
UnitTy -> UnitTy ->
binders (FuncTy [RefTy p (VarTy "q")] UnitTy StaticLifetimeTy) binders
(FuncTy [p, t] p StaticLifetimeTy) (FuncTy [RefTy p (VarTy "q")] UnitTy StaticLifetimeTy)
(FuncTy [RefTy p (VarTy "q"), t] UnitTy StaticLifetimeTy) (FuncTy [p, t] p StaticLifetimeTy)
(FuncTy [p, RefTy (FuncTy [] UnitTy (VarTy "fq")) (VarTy "q")] 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) binders
(FuncTy [p, t] p StaticLifetimeTy) (FuncTy [RefTy p (VarTy "q")] (RefTy t (VarTy "q")) StaticLifetimeTy)
(FuncTy [RefTy p (VarTy "q"), t] UnitTy StaticLifetimeTy) (FuncTy [p, t] p StaticLifetimeTy)
(FuncTy [p, RefTy (FuncTy [t] t (VarTy "fq")) (VarTy "q")] p StaticLifetimeTy) (FuncTy [RefTy p (VarTy "q"), t] UnitTy StaticLifetimeTy)
where Just t = xobjToTy typeXObj (FuncTy [p, RefTy (FuncTy [t] t (VarTy "fq")) (VarTy "q")] p StaticLifetimeTy)
memberName = getName nameXObj where
binders getterSig setterSig mutatorSig updaterSig = Just t = xobjToTy typeXObj
[instanceBinderWithDeps (SymPath insidePath memberName) getterSig (templateGetter (mangle memberName) t) ("gets the `" ++ memberName ++ "` property of a `" ++ typeName ++ "`.") memberName = getName nameXObj
, if isTypeGeneric t binders getterSig setterSig mutatorSig updaterSig =
then (templateGenericSetter insidePath p t memberName, []) [ instanceBinderWithDeps (SymPath insidePath memberName) getterSig (templateGetter (mangle memberName) t) ("gets the `" ++ memberName ++ "` property of a `" ++ typeName ++ "`."),
else instanceBinderWithDeps (SymPath insidePath ("set-" ++ memberName)) setterSig (templateSetter typeEnv env (mangle memberName) t) ("sets the `" ++ memberName ++ "` property of a `" ++ typeName ++ "`.") if isTypeGeneric t
, if isTypeGeneric t then (templateGenericSetter insidePath p t memberName, [])
then (templateGenericMutatingSetter insidePath p t memberName, []) else instanceBinderWithDeps (SymPath insidePath ("set-" ++ memberName)) setterSig (templateSetter typeEnv env (mangle memberName) t) ("sets the `" ++ memberName ++ "` property of a `" ++ typeName ++ "`."),
else instanceBinderWithDeps (SymPath insidePath ("set-" ++ memberName ++ "!")) mutatorSig (templateMutatingSetter typeEnv env (mangle memberName) t) ("sets the `" ++ memberName ++ "` property of a `" ++ typeName ++ "` in place.") if isTypeGeneric t
,instanceBinderWithDeps (SymPath insidePath ("update-" ++ memberName)) then (templateGenericMutatingSetter insidePath p t memberName, [])
updaterSig else instanceBinderWithDeps (SymPath insidePath ("set-" ++ memberName ++ "!")) mutatorSig (templateMutatingSetter typeEnv env (mangle memberName) t) ("sets the `" ++ memberName ++ "` property of a `" ++ typeName ++ "` in place."),
(templateUpdater (mangle memberName) t) instanceBinderWithDeps
("updates the `" ++ memberName ++ "` property of a `" ++ typeName ++ "` using a function `f`.") (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. -- | The template for getters of a deftype.
templateGetter :: String -> Ty -> Template templateGetter :: String -> Ty -> Template
@ -117,14 +126,16 @@ templateGetter member memberTy =
Template Template
(FuncTy [RefTy (VarTy "p") (VarTy "q")] (VarTy "t") StaticLifetimeTy) (FuncTy [RefTy (VarTy "p") (VarTy "q")] (VarTy "t") StaticLifetimeTy)
(const (toTemplate "$t $NAME($(Ref p) p)")) (const (toTemplate "$t $NAME($(Ref p) p)"))
(\(FuncTy [_] retTy _) -> ( \(FuncTy [_] retTy _) ->
case retTy of case retTy of
(RefTy UnitTy _) -> toTemplate " $DECL { void* ptr = NULL; return ptr; }\n" (RefTy UnitTy _) -> toTemplate " $DECL { void* ptr = NULL; return ptr; }\n"
_ -> let fixForVoidStarMembers = _ ->
let fixForVoidStarMembers =
if isFunctionType memberTy && not (isTypeGeneric memberTy) if isFunctionType memberTy && not (isTypeGeneric memberTy)
then "(" ++ tyToCLambdaFix (RefTy memberTy (VarTy "q")) ++ ")" then "(" ++ tyToCLambdaFix (RefTy memberTy (VarTy "q")) ++ ")"
else "" else ""
in toTemplate ("$DECL { return " ++ fixForVoidStarMembers ++ "(&(p->" ++ member ++ ")); }\n")) in toTemplate ("$DECL { return " ++ fixForVoidStarMembers ++ "(&(p->" ++ member ++ ")); }\n")
)
(const []) (const [])
-- | The template for setters of a concrete deftype. -- | The template for setters of a concrete deftype.
@ -138,47 +149,64 @@ templateSetter _ _ _ UnitTy =
(const []) (const [])
templateSetter typeEnv env memberName memberTy = templateSetter typeEnv env memberName memberTy =
let callToDelete = memberDeletion typeEnv env (memberName, memberTy) let callToDelete = memberDeletion typeEnv env (memberName, memberTy)
in in Template
Template (FuncTy [VarTy "p", VarTy "t"] (VarTy "p") StaticLifetimeTy)
(FuncTy [VarTy "p", VarTy "t"] (VarTy "p") StaticLifetimeTy) (const (toTemplate "$p $NAME($p p, $t newValue)"))
(const (toTemplate "$p $NAME($p p, $t newValue)")) ( const
(const (toTemplate (unlines ["$DECL {" ( toTemplate
,callToDelete ( unlines
," p." ++ memberName ++ " = newValue;" [ "$DECL {",
," return p;" callToDelete,
,"}\n"]))) " p." ++ memberName ++ " = newValue;",
(\_ -> if | isManaged typeEnv memberTy -> depsOfPolymorphicFunction typeEnv env [] "delete" (typesDeleterFunctionType memberTy) " return p;",
| isFunctionType memberTy -> [defineFunctionTypeAlias memberTy] "}\n"
| otherwise -> []) ]
)
)
)
( \_ ->
if | isManaged typeEnv memberTy -> depsOfPolymorphicFunction typeEnv env [] "delete" (typesDeleterFunctionType memberTy)
| isFunctionType memberTy -> [defineFunctionTypeAlias memberTy]
| otherwise -> []
)
-- | The template for setters of a generic deftype. -- | The template for setters of a generic deftype.
templateGenericSetter :: [String] -> Ty -> Ty -> String -> (String, Binder) templateGenericSetter :: [String] -> Ty -> Ty -> String -> (String, Binder)
templateGenericSetter pathStrings originalStructTy@(StructTy (ConcreteNameTy typeName) _) membTy memberName = templateGenericSetter pathStrings originalStructTy@(StructTy (ConcreteNameTy typeName) _) membTy memberName =
defineTypeParameterizedTemplate templateCreator path (FuncTy [originalStructTy, membTy] originalStructTy StaticLifetimeTy) docs defineTypeParameterizedTemplate templateCreator path (FuncTy [originalStructTy, membTy] originalStructTy StaticLifetimeTy) docs
where path = SymPath pathStrings ("set-" ++ memberName) where
t = FuncTy [VarTy "p", VarTy "t"] (VarTy "p") StaticLifetimeTy path = SymPath pathStrings ("set-" ++ memberName)
docs = "sets the `" ++ memberName ++ "` property of a `" ++ typeName ++ "`." t = FuncTy [VarTy "p", VarTy "t"] (VarTy "p") StaticLifetimeTy
templateCreator = TemplateCreator $ docs = "sets the `" ++ memberName ++ "` property of a `" ++ typeName ++ "`."
\typeEnv env -> templateCreator = TemplateCreator $
Template \typeEnv env ->
t Template
(\(FuncTy [_, memberTy] _ _) -> t
( \(FuncTy [_, memberTy] _ _) ->
case memberTy of case memberTy of
UnitTy -> (toTemplate "$p $NAME($p p)") UnitTy -> (toTemplate "$p $NAME($p p)")
_ -> (toTemplate "$p $NAME($p p, $t newValue)")) _ -> (toTemplate "$p $NAME($p p, $t newValue)")
(\(FuncTy [_, memberTy] _ _) -> )
let callToDelete = memberDeletion typeEnv env (memberName, memberTy) ( \(FuncTy [_, memberTy] _ _) ->
in case memberTy of let callToDelete = memberDeletion typeEnv env (memberName, memberTy)
UnitTy -> toTemplate "$DECL { return p; }\n" in case memberTy of
_ -> toTemplate (unlines ["$DECL {" UnitTy -> toTemplate "$DECL { return p; }\n"
,callToDelete _ ->
," p." ++ memberName ++ " = newValue;" toTemplate
," return p;" ( unlines
,"}\n"])) [ "$DECL {",
(\(FuncTy [_, memberTy] _ _) -> callToDelete,
if isManaged typeEnv memberTy " p." ++ memberName ++ " = newValue;",
then depsOfPolymorphicFunction typeEnv env [] "delete" (typesDeleterFunctionType memberTy) " return p;",
else []) "}\n"
]
)
)
( \(FuncTy [_, memberTy] _ _) ->
if isManaged typeEnv memberTy
then depsOfPolymorphicFunction typeEnv env [] "delete" (typesDeleterFunctionType memberTy)
else []
)
-- | The template for mutating setters of a deftype. -- | The template for mutating setters of a deftype.
templateMutatingSetter :: TypeEnv -> Env -> String -> Ty -> Template templateMutatingSetter :: TypeEnv -> Env -> String -> Ty -> Template
@ -191,42 +219,58 @@ templateMutatingSetter _ _ _ UnitTy =
(const []) (const [])
templateMutatingSetter typeEnv env memberName memberTy = templateMutatingSetter typeEnv env memberName memberTy =
let callToDelete = memberRefDeletion typeEnv env (memberName, memberTy) let callToDelete = memberRefDeletion typeEnv env (memberName, memberTy)
in Template in Template
(FuncTy [RefTy (VarTy "p") (VarTy "q"), VarTy "t"] UnitTy StaticLifetimeTy) (FuncTy [RefTy (VarTy "p") (VarTy "q"), VarTy "t"] UnitTy StaticLifetimeTy)
(const (toTemplate "void $NAME($p* pRef, $t newValue)")) (const (toTemplate "void $NAME($p* pRef, $t newValue)"))
(const (toTemplate (unlines ["$DECL {" ( const
,callToDelete ( toTemplate
," pRef->" ++ memberName ++ " = newValue;" ( unlines
,"}\n"]))) [ "$DECL {",
(const []) callToDelete,
" pRef->" ++ memberName ++ " = newValue;",
"}\n"
]
)
)
)
(const [])
-- | The template for mutating setters of a generic deftype. -- | The template for mutating setters of a generic deftype.
templateGenericMutatingSetter :: [String] -> Ty -> Ty -> String -> (String, Binder) templateGenericMutatingSetter :: [String] -> Ty -> Ty -> String -> (String, Binder)
templateGenericMutatingSetter pathStrings originalStructTy@(StructTy (ConcreteNameTy typeName) _) membTy memberName = templateGenericMutatingSetter pathStrings originalStructTy@(StructTy (ConcreteNameTy typeName) _) membTy memberName =
defineTypeParameterizedTemplate templateCreator path (FuncTy [(RefTy originalStructTy (VarTy "q")), membTy] UnitTy StaticLifetimeTy) docs defineTypeParameterizedTemplate templateCreator path (FuncTy [(RefTy originalStructTy (VarTy "q")), membTy] UnitTy StaticLifetimeTy) docs
where path = SymPath pathStrings ("set-" ++ memberName ++ "!") where
t = FuncTy [RefTy (VarTy "p") (VarTy "q"), VarTy "t"] UnitTy StaticLifetimeTy path = SymPath pathStrings ("set-" ++ memberName ++ "!")
docs = "sets the `" ++ memberName ++ "` property of a `" ++ typeName ++ "` in place." t = FuncTy [RefTy (VarTy "p") (VarTy "q"), VarTy "t"] UnitTy StaticLifetimeTy
templateCreator = TemplateCreator $ docs = "sets the `" ++ memberName ++ "` property of a `" ++ typeName ++ "` in place."
\typeEnv env -> templateCreator = TemplateCreator $
Template \typeEnv env ->
t Template
(\(FuncTy [_, memberTy] _ _) -> t
( \(FuncTy [_, memberTy] _ _) ->
case memberTy of case memberTy of
UnitTy -> (toTemplate "void $NAME($p* pRef)") UnitTy -> (toTemplate "void $NAME($p* pRef)")
_ -> (toTemplate "void $NAME($p* pRef, $t newValue)")) _ -> (toTemplate "void $NAME($p* pRef, $t newValue)")
(\(FuncTy [_, memberTy] _ _) -> )
let callToDelete = memberRefDeletion typeEnv env (memberName, memberTy) ( \(FuncTy [_, memberTy] _ _) ->
in case memberTy of let callToDelete = memberRefDeletion typeEnv env (memberName, memberTy)
UnitTy -> (toTemplate "$DECL { return; }\n") in case memberTy of
_ -> toTemplate (unlines ["$DECL {" UnitTy -> (toTemplate "$DECL { return; }\n")
,callToDelete _ ->
," pRef->" ++ memberName ++ " = newValue;" toTemplate
,"}\n"])) ( unlines
(\(FuncTy [_, memberTy] _ _) -> [ "$DECL {",
if isManaged typeEnv memberTy callToDelete,
then depsOfPolymorphicFunction typeEnv env [] "delete" (typesDeleterFunctionType memberTy) " pRef->" ++ memberName ++ " = newValue;",
else []) "}\n"
]
)
)
( \(FuncTy [_, memberTy] _ _) ->
if isManaged typeEnv memberTy
then depsOfPolymorphicFunction typeEnv env [] "delete" (typesDeleterFunctionType memberTy)
else []
)
-- | The template for updater functions of a deftype. -- | The template for updater functions of a deftype.
-- | (allows changing a variable by passing an transformation function). -- | (allows changing a variable by passing an transformation function).
@ -235,32 +279,44 @@ templateUpdater _ UnitTy =
Template Template
(FuncTy [VarTy "p", RefTy (FuncTy [] UnitTy (VarTy "fq")) (VarTy "q")] (VarTy "p") StaticLifetimeTy) (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) (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"))) (const (toTemplate ("$DECL { " ++ templateCodeForCallingLambda "(*updater)" (FuncTy [] UnitTy (VarTy "fq")) [] ++ "; return p;}\n")))
(\(FuncTy [_, RefTy t@(FuncTy fArgTys fRetTy _) _] _ _) -> ( \(FuncTy [_, RefTy t@(FuncTy fArgTys fRetTy _) _] _ _) ->
[defineFunctionTypeAlias t, defineFunctionTypeAlias (FuncTy (lambdaEnvTy : fArgTys) fRetTy StaticLifetimeTy)]) [defineFunctionTypeAlias t, defineFunctionTypeAlias (FuncTy (lambdaEnvTy : fArgTys) fRetTy StaticLifetimeTy)]
)
templateUpdater member _ = templateUpdater member _ =
Template Template
(FuncTy [VarTy "p", RefTy (FuncTy [VarTy "t"] (VarTy "t") (VarTy "fq")) (VarTy "q")] (VarTy "p") StaticLifetimeTy) (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 "$p $NAME($p p, Lambda *updater)")) -- "Lambda" used to be: $(Fn [t] t)
(const (toTemplate (unlines ["$DECL {" ( const
," p." ++ member ++ " = " ++ templateCodeForCallingLambda "(*updater)" (FuncTy [VarTy "t"] (VarTy "t") (VarTy "fq")) ["p." ++ member] ++ ";" ( toTemplate
," return p;" ( unlines
,"}\n"]))) [ "$DECL {",
(\(FuncTy [_, RefTy t@(FuncTy fArgTys fRetTy _) _] _ _) -> " p." ++ member ++ " = " ++ templateCodeForCallingLambda "(*updater)" (FuncTy [VarTy "t"] (VarTy "t") (VarTy "fq")) ["p." ++ member] ++ ";",
if isTypeGeneric fRetTy " return p;",
then [] "}\n"
else [defineFunctionTypeAlias t, defineFunctionTypeAlias (FuncTy (lambdaEnvTy : fArgTys) fRetTy StaticLifetimeTy)]) ]
)
)
)
( \(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. -- | Helper function to create the binder for the 'init' template.
binderForInit :: [String] -> Ty -> [XObj] -> Either TypeError (String, Binder) binderForInit :: [String] -> Ty -> [XObj] -> Either TypeError (String, Binder)
binderForInit insidePath structTy@(StructTy (ConcreteNameTy typeName) _) [XObj (Arr membersXObjs) _ _] = binderForInit insidePath structTy@(StructTy (ConcreteNameTy typeName) _) [XObj (Arr membersXObjs) _ _] =
if isTypeGeneric structTy if isTypeGeneric structTy
then Right (genericInit StackAlloc insidePath structTy membersXObjs) then Right (genericInit StackAlloc insidePath structTy membersXObjs)
else Right $ instanceBinder (SymPath insidePath "init") else
(FuncTy (initArgListTypes membersXObjs) structTy StaticLifetimeTy) Right $
(concreteInit StackAlloc structTy membersXObjs) instanceBinder
("creates a `" ++ typeName ++ "`.") (SymPath insidePath "init")
(FuncTy (initArgListTypes membersXObjs) structTy StaticLifetimeTy)
(concreteInit StackAlloc structTy membersXObjs)
("creates a `" ++ typeName ++ "`.")
-- | Generate a list of types from a deftype declaration. -- | Generate a list of types from a deftype declaration.
initArgListTypes :: [XObj] -> [Ty] initArgListTypes :: [XObj] -> [Ty]
@ -272,63 +328,74 @@ concreteInit :: AllocationMode -> Ty -> [XObj] -> Template
concreteInit allocationMode originalStructTy@(StructTy (ConcreteNameTy typeName) _) membersXObjs = concreteInit allocationMode originalStructTy@(StructTy (ConcreteNameTy typeName) _) membersXObjs =
Template Template
(FuncTy (map snd (memberXObjsToPairs membersXObjs)) (VarTy "p") StaticLifetimeTy) (FuncTy (map snd (memberXObjsToPairs membersXObjs)) (VarTy "p") StaticLifetimeTy)
(\(FuncTy _ concreteStructTy _) -> ( \(FuncTy _ concreteStructTy _) ->
let mappings = unifySignatures originalStructTy concreteStructTy let mappings = unifySignatures originalStructTy concreteStructTy
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
memberPairs = memberXObjsToPairs correctedMembers memberPairs = memberXObjsToPairs correctedMembers
in (toTemplate $ "$p $NAME(" ++ joinWithComma (map memberArg (unitless memberPairs)) ++ ")")) in (toTemplate $ "$p $NAME(" ++ joinWithComma (map memberArg (unitless memberPairs)) ++ ")")
(\(FuncTy _ concreteStructTy _) -> )
let mappings = unifySignatures originalStructTy concreteStructTy ( \(FuncTy _ concreteStructTy _) ->
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs let mappings = unifySignatures originalStructTy concreteStructTy
in (tokensForInit allocationMode typeName correctedMembers)) correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
(\FuncTy{} -> []) in (tokensForInit allocationMode typeName correctedMembers)
where unitless = remove (isUnit . snd) )
(\FuncTy {} -> [])
where
unitless = remove (isUnit . snd)
-- | The template for the 'init' and 'new' functions for a generic deftype. -- | The template for the 'init' and 'new' functions for a generic deftype.
genericInit :: AllocationMode -> [String] -> Ty -> [XObj] -> (String, Binder) genericInit :: AllocationMode -> [String] -> Ty -> [XObj] -> (String, Binder)
genericInit allocationMode pathStrings originalStructTy@(StructTy (ConcreteNameTy typeName) _) membersXObjs = genericInit allocationMode pathStrings originalStructTy@(StructTy (ConcreteNameTy typeName) _) membersXObjs =
defineTypeParameterizedTemplate templateCreator path t docs defineTypeParameterizedTemplate templateCreator path t docs
where path = SymPath pathStrings "init" where
t = FuncTy (map snd (memberXObjsToPairs membersXObjs)) originalStructTy StaticLifetimeTy path = SymPath pathStrings "init"
docs = "creates a `" ++ typeName ++ "`." t = FuncTy (map snd (memberXObjsToPairs membersXObjs)) originalStructTy StaticLifetimeTy
templateCreator = TemplateCreator $ docs = "creates a `" ++ typeName ++ "`."
\typeEnv _ -> templateCreator = TemplateCreator $
Template \typeEnv _ ->
(FuncTy (map snd (memberXObjsToPairs membersXObjs)) (VarTy "p") StaticLifetimeTy) Template
(\(FuncTy _ concreteStructTy _) -> (FuncTy (map snd (memberXObjsToPairs membersXObjs)) (VarTy "p") StaticLifetimeTy)
let mappings = unifySignatures originalStructTy concreteStructTy ( \(FuncTy _ concreteStructTy _) ->
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
memberPairs = memberXObjsToPairs correctedMembers
in (toTemplate $ "$p $NAME(" ++ joinWithComma (map memberArg (remove (isUnit . snd) memberPairs)) ++ ")"))
(\(FuncTy _ concreteStructTy _) ->
let mappings = unifySignatures originalStructTy concreteStructTy let mappings = unifySignatures originalStructTy concreteStructTy
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
in (tokensForInit allocationMode typeName correctedMembers)) memberPairs = memberXObjsToPairs correctedMembers
(\(FuncTy _ concreteStructTy _) -> in (toTemplate $ "$p $NAME(" ++ joinWithComma (map memberArg (remove (isUnit . snd) memberPairs)) ++ ")")
case concretizeType typeEnv concreteStructTy of )
Left err -> error (show err ++ ". This error should not crash the compiler - change return type to Either here.") ( \(FuncTy _ concreteStructTy _) ->
Right ok -> ok 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 -> String -> [XObj] -> [Token]
tokensForInit allocationMode typeName membersXObjs = tokensForInit allocationMode typeName membersXObjs =
toTemplate $ unlines [ "$DECL {" toTemplate $
, case allocationMode of unlines
StackAlloc -> case unitless of [ "$DECL {",
-- if this is truly a memberless struct, init it to 0; case allocationMode of
-- This can happen, e.g. in cases where *all* members of the struct are of type Unit. StackAlloc -> case unitless of
-- Since we do not generate members for Unit types. -- if this is truly a memberless struct, init it to 0;
[] -> " $p instance = {};" -- This can happen, e.g. in cases where *all* members of the struct are of type Unit.
_ -> " $p instance;" -- Since we do not generate members for Unit types.
HeapAlloc -> " $p instance = CARP_MALLOC(sizeof(" ++ typeName ++ "));" [] -> " $p instance = {};"
, assignments membersXObjs _ -> " $p instance;"
, " return instance;" HeapAlloc -> " $p instance = CARP_MALLOC(sizeof(" ++ typeName ++ "));",
, "}"] assignments membersXObjs,
where assignments [] = " instance.__dummy = 0;" " return instance;",
assignments _ = go $ unitless "}"
where go [] = "" ]
go xobjs = joinLines $ memberAssignment allocationMode . fst <$> xobjs where
unitless = remove (isUnit . snd) (memberXObjsToPairs membersXObjs) 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. -- | Creates the C code for an arg to the init function.
-- | i.e. "(deftype A [x Int])" will generate "int x" which -- | 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 -> [String] -> Ty -> [XObj] -> String -> Either TypeError ((String, Binder), [XObj])
binderForStrOrPrn typeEnv env insidePath structTy@(StructTy (ConcreteNameTy typeName) _) [XObj (Arr membersXObjs) _ _] strOrPrn = binderForStrOrPrn typeEnv env insidePath structTy@(StructTy (ConcreteNameTy typeName) _) [XObj (Arr membersXObjs) _ _] strOrPrn =
if isTypeGeneric structTy if isTypeGeneric structTy
then Right (genericStr insidePath structTy membersXObjs strOrPrn, []) then Right (genericStr insidePath structTy membersXObjs strOrPrn, [])
else Right (instanceBinderWithDeps (SymPath insidePath strOrPrn) else
(FuncTy [RefTy structTy (VarTy "q")] StringTy StaticLifetimeTy) Right
(concreteStr typeEnv env structTy (memberXObjsToPairs membersXObjs) strOrPrn) ( instanceBinderWithDeps
("converts a `" ++ typeName ++ "` to a string.")) (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. -- | The template for the 'str' function for a concrete deftype.
concreteStr :: TypeEnv -> Env -> Ty -> [(String, Ty)] -> String -> Template concreteStr :: TypeEnv -> Env -> Ty -> [(String, Ty)] -> String -> Template
@ -362,142 +433,175 @@ concreteStr typeEnv env concreteStructTy@(StructTy (ConcreteNameTy typeName) _)
Template Template
(FuncTy [RefTy concreteStructTy (VarTy "q")] StringTy StaticLifetimeTy) (FuncTy [RefTy concreteStructTy (VarTy "q")] StringTy StaticLifetimeTy)
(\(FuncTy [RefTy structTy _] StringTy _) -> toTemplate $ "String $NAME(" ++ tyToCLambdaFix structTy ++ " *p)") (\(FuncTy [RefTy structTy _] StringTy _) -> toTemplate $ "String $NAME(" ++ tyToCLambdaFix structTy ++ " *p)")
(\(FuncTy [RefTy (StructTy _ _) _] StringTy _) -> ( \(FuncTy [RefTy (StructTy _ _) _] StringTy _) ->
tokensForStr typeEnv env typeName memberPairs concreteStructTy) tokensForStr typeEnv env typeName memberPairs concreteStructTy
(\(FuncTy [RefTy (StructTy _ _) (VarTy "q")] StringTy _) -> )
concatMap (depsOfPolymorphicFunction typeEnv env [] "prn" . typesStrFunctionType typeEnv) ( \(FuncTy [RefTy (StructTy _ _) (VarTy "q")] StringTy _) ->
(remove isFullyGenericType (map snd memberPairs))) concatMap
(depsOfPolymorphicFunction typeEnv env [] "prn" . typesStrFunctionType typeEnv)
(remove isFullyGenericType (map snd memberPairs))
)
-- | The template for the 'str' function for a generic deftype. -- | The template for the 'str' function for a generic deftype.
genericStr :: [String] -> Ty -> [XObj] -> String -> (String, Binder) genericStr :: [String] -> Ty -> [XObj] -> String -> (String, Binder)
genericStr pathStrings originalStructTy@(StructTy (ConcreteNameTy typeName) _) membersXObjs strOrPrn = genericStr pathStrings originalStructTy@(StructTy (ConcreteNameTy typeName) _) membersXObjs strOrPrn =
defineTypeParameterizedTemplate templateCreator path t docs defineTypeParameterizedTemplate templateCreator path t docs
where path = SymPath pathStrings strOrPrn where
t = FuncTy [RefTy originalStructTy (VarTy "q")] StringTy StaticLifetimeTy path = SymPath pathStrings strOrPrn
docs = "converts a `" ++ typeName ++ "` to a string." t = FuncTy [RefTy originalStructTy (VarTy "q")] StringTy StaticLifetimeTy
templateCreator = TemplateCreator $ docs = "converts a `" ++ typeName ++ "` to a string."
\typeEnv env -> templateCreator = TemplateCreator $
Template \typeEnv env ->
t Template
(\(FuncTy [RefTy concreteStructTy _] StringTy _) -> t
toTemplate $ "String $NAME(" ++ tyToCLambdaFix concreteStructTy ++ " *p)") ( \(FuncTy [RefTy concreteStructTy _] StringTy _) ->
(\(FuncTy [RefTy concreteStructTy@(StructTy _ _) _] StringTy _) -> toTemplate $ "String $NAME(" ++ tyToCLambdaFix concreteStructTy ++ " *p)"
let mappings = unifySignatures originalStructTy concreteStructTy )
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs ( \(FuncTy [RefTy concreteStructTy@(StructTy _ _) _] StringTy _) ->
memberPairs = memberXObjsToPairs correctedMembers let mappings = unifySignatures originalStructTy concreteStructTy
in tokensForStr typeEnv env typeName memberPairs concreteStructTy) correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
(\ft@(FuncTy [RefTy concreteStructTy@(StructTy _ _) _] StringTy _) -> memberPairs = memberXObjsToPairs correctedMembers
let mappings = unifySignatures originalStructTy concreteStructTy in tokensForStr typeEnv env typeName memberPairs concreteStructTy
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs )
memberPairs = memberXObjsToPairs correctedMembers ( \ft@(FuncTy [RefTy concreteStructTy@(StructTy _ _) _] StringTy _) ->
in concatMap (depsOfPolymorphicFunction typeEnv env [] "prn" . typesStrFunctionType typeEnv) let mappings = unifySignatures originalStructTy concreteStructTy
(remove isFullyGenericType (map snd memberPairs)) correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
++ memberPairs = memberXObjsToPairs correctedMembers
(if isTypeGeneric concreteStructTy then [] else [defineFunctionTypeAlias ft])) 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 -> String -> [(String, Ty)] -> Ty -> [Token]
tokensForStr typeEnv env typeName memberPairs concreteStructTy = tokensForStr typeEnv env typeName memberPairs concreteStructTy =
toTemplate $ unlines [ "$DECL {" toTemplate $
, " // convert members to String here:" unlines
, " String temp = NULL;" [ "$DECL {",
, " int tempsize = 0;" " // convert members to String here:",
, " (void)tempsize; // that way we remove the occasional unused warning " " String temp = NULL;",
, calculateStructStrSize typeEnv env memberPairs concreteStructTy " int tempsize = 0;",
, " String buffer = CARP_MALLOC(size);" " (void)tempsize; // that way we remove the occasional unused warning ",
, " String bufferPtr = buffer;" calculateStructStrSize typeEnv env memberPairs concreteStructTy,
, "" " String buffer = CARP_MALLOC(size);",
, " sprintf(bufferPtr, \"(%s \", \"" ++ typeName ++ "\");" " String bufferPtr = buffer;",
, " bufferPtr += strlen(\"" ++ typeName ++ "\") + 2;\n" "",
, joinLines (map (memberPrn typeEnv env) memberPairs) " sprintf(bufferPtr, \"(%s \", \"" ++ typeName ++ "\");",
, " bufferPtr--;" " bufferPtr += strlen(\"" ++ typeName ++ "\") + 2;\n",
, " sprintf(bufferPtr, \")\");" joinLines (map (memberPrn typeEnv env) memberPairs),
, " return buffer;" " bufferPtr--;",
, "}"] " sprintf(bufferPtr, \")\");",
" return buffer;",
"}"
]
-- | Figure out how big the string needed for the string representation of the struct has to be. -- | Figure out how big the string needed for the string representation of the struct has to be.
calculateStructStrSize :: TypeEnv -> Env -> [(String, Ty)] -> Ty -> String calculateStructStrSize :: TypeEnv -> Env -> [(String, Ty)] -> Ty -> String
calculateStructStrSize typeEnv env members (StructTy (ConcreteNameTy name) _) = calculateStructStrSize typeEnv env members (StructTy (ConcreteNameTy name) _) =
" int size = snprintf(NULL, 0, \"(%s )\", \"" ++ name ++ "\");\n" ++ " int size = snprintf(NULL, 0, \"(%s )\", \"" ++ name ++ "\");\n"
unlines (map (memberPrnSize typeEnv env) members) ++ unlines (map (memberPrnSize typeEnv env) members)
-- | Generate C code for assigning to a member variable. -- | Generate C code for assigning to a member variable.
-- | Needs to know if the instance is a pointer or stack variable. -- | Needs to know if the instance is a pointer or stack variable.
memberAssignment :: AllocationMode -> String -> String memberAssignment :: AllocationMode -> String -> String
memberAssignment allocationMode memberName = " instance" ++ sep ++ memberName ++ " = " ++ memberName ++ ";" memberAssignment allocationMode memberName = " instance" ++ sep ++ memberName ++ " = " ++ memberName ++ ";"
where sep = case allocationMode of where
StackAlloc -> "." sep = case allocationMode of
HeapAlloc -> "->" StackAlloc -> "."
HeapAlloc -> "->"
-- | Helper function to create the binder for the 'delete' template. -- | Helper function to create the binder for the 'delete' template.
binderForDelete :: TypeEnv -> Env -> [String] -> Ty -> [XObj] -> Either TypeError ((String, Binder), [XObj]) binderForDelete :: TypeEnv -> Env -> [String] -> Ty -> [XObj] -> Either TypeError ((String, Binder), [XObj])
binderForDelete typeEnv env insidePath structTy@(StructTy (ConcreteNameTy typeName) _) [XObj (Arr membersXObjs) _ _] = binderForDelete typeEnv env insidePath structTy@(StructTy (ConcreteNameTy typeName) _) [XObj (Arr membersXObjs) _ _] =
if isTypeGeneric structTy if isTypeGeneric structTy
then Right (genericDelete insidePath structTy membersXObjs, []) then Right (genericDelete insidePath structTy membersXObjs, [])
else Right (instanceBinderWithDeps (SymPath insidePath "delete") else
(FuncTy [structTy] UnitTy StaticLifetimeTy) Right
(concreteDelete typeEnv env (memberXObjsToPairs membersXObjs)) ( instanceBinderWithDeps
("deletes a `" ++ typeName ++"`.")) (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. -- | The template for the 'delete' function of a generic deftype.
genericDelete :: [String] -> Ty -> [XObj] -> (String, Binder) genericDelete :: [String] -> Ty -> [XObj] -> (String, Binder)
genericDelete pathStrings originalStructTy@(StructTy (ConcreteNameTy typeName) _) membersXObjs = genericDelete pathStrings originalStructTy@(StructTy (ConcreteNameTy typeName) _) membersXObjs =
defineTypeParameterizedTemplate templateCreator path (FuncTy [originalStructTy] UnitTy StaticLifetimeTy) docs defineTypeParameterizedTemplate templateCreator path (FuncTy [originalStructTy] UnitTy StaticLifetimeTy) docs
where path = SymPath pathStrings "delete" where
t = FuncTy [VarTy "p"] UnitTy StaticLifetimeTy path = SymPath pathStrings "delete"
docs = "deletes a `" ++ typeName ++ "`. Should usually not be called manually." t = FuncTy [VarTy "p"] UnitTy StaticLifetimeTy
templateCreator = TemplateCreator $ docs = "deletes a `" ++ typeName ++ "`. Should usually not be called manually."
\typeEnv env -> templateCreator = TemplateCreator $
Template \typeEnv env ->
t Template
(const (toTemplate "void $NAME($p p)")) t
(\(FuncTy [concreteStructTy] UnitTy _) -> (const (toTemplate "void $NAME($p p)"))
let mappings = unifySignatures originalStructTy concreteStructTy ( \(FuncTy [concreteStructTy] UnitTy _) ->
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs let mappings = unifySignatures originalStructTy concreteStructTy
memberPairs = memberXObjsToPairs correctedMembers correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
in (toTemplate $ unlines [ "$DECL {" memberPairs = memberXObjsToPairs correctedMembers
, joinLines (map (memberDeletion typeEnv env) memberPairs) in ( toTemplate $
, "}"])) unlines
(\(FuncTy [concreteStructTy] UnitTy _) -> [ "$DECL {",
let mappings = unifySignatures originalStructTy concreteStructTy joinLines (map (memberDeletion typeEnv env) memberPairs),
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs "}"
memberPairs = memberXObjsToPairs correctedMembers ]
in if isTypeGeneric concreteStructTy )
then [] )
else concatMap (depsOfPolymorphicFunction typeEnv env [] "delete" . typesDeleterFunctionType) ( \(FuncTy [concreteStructTy] UnitTy _) ->
(filter (isManaged typeEnv) (map snd memberPairs))) 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. -- | Helper function to create the binder for the 'copy' template.
binderForCopy :: TypeEnv -> Env -> [String] -> Ty -> [XObj] -> Either TypeError ((String, Binder), [XObj]) binderForCopy :: TypeEnv -> Env -> [String] -> Ty -> [XObj] -> Either TypeError ((String, Binder), [XObj])
binderForCopy typeEnv env insidePath structTy@(StructTy (ConcreteNameTy typeName) _) [XObj (Arr membersXObjs) _ _] = binderForCopy typeEnv env insidePath structTy@(StructTy (ConcreteNameTy typeName) _) [XObj (Arr membersXObjs) _ _] =
if isTypeGeneric structTy if isTypeGeneric structTy
then Right (genericCopy insidePath structTy membersXObjs, []) then Right (genericCopy insidePath structTy membersXObjs, [])
else Right (instanceBinderWithDeps (SymPath insidePath "copy") else
(FuncTy [RefTy structTy (VarTy "q")] structTy StaticLifetimeTy) Right
(concreteCopy typeEnv env (memberXObjsToPairs membersXObjs)) ( instanceBinderWithDeps
("copies a `" ++ typeName ++ "`.")) (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. -- | The template for the 'copy' function of a generic deftype.
genericCopy :: [String] -> Ty -> [XObj] -> (String, Binder) genericCopy :: [String] -> Ty -> [XObj] -> (String, Binder)
genericCopy pathStrings originalStructTy@(StructTy (ConcreteNameTy typeName) _) membersXObjs = genericCopy pathStrings originalStructTy@(StructTy (ConcreteNameTy typeName) _) membersXObjs =
defineTypeParameterizedTemplate templateCreator path (FuncTy [RefTy originalStructTy (VarTy "q")] originalStructTy StaticLifetimeTy) docs defineTypeParameterizedTemplate templateCreator path (FuncTy [RefTy originalStructTy (VarTy "q")] originalStructTy StaticLifetimeTy) docs
where path = SymPath pathStrings "copy" where
t = FuncTy [RefTy (VarTy "p") (VarTy "q")] (VarTy "p") StaticLifetimeTy path = SymPath pathStrings "copy"
docs = "copies the `" ++ typeName ++ "`." t = FuncTy [RefTy (VarTy "p") (VarTy "q")] (VarTy "p") StaticLifetimeTy
templateCreator = TemplateCreator $ docs = "copies the `" ++ typeName ++ "`."
\typeEnv env -> templateCreator = TemplateCreator $
Template \typeEnv env ->
t Template
(const (toTemplate "$p $NAME($p* pRef)")) t
(\(FuncTy [RefTy concreteStructTy _] _ _) -> (const (toTemplate "$p $NAME($p* pRef)"))
let mappings = unifySignatures originalStructTy concreteStructTy ( \(FuncTy [RefTy concreteStructTy _] _ _) ->
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs let mappings = unifySignatures originalStructTy concreteStructTy
memberPairs = memberXObjsToPairs correctedMembers correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
in tokensForCopy typeEnv env memberPairs) memberPairs = memberXObjsToPairs correctedMembers
(\(FuncTy [RefTy concreteStructTy _] _ _) -> in tokensForCopy typeEnv env memberPairs
let mappings = unifySignatures originalStructTy concreteStructTy )
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs ( \(FuncTy [RefTy concreteStructTy _] _ _) ->
memberPairs = memberXObjsToPairs correctedMembers let mappings = unifySignatures originalStructTy concreteStructTy
in if isTypeGeneric concreteStructTy correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
then [] memberPairs = memberXObjsToPairs correctedMembers
else concatMap (depsOfPolymorphicFunction typeEnv env [] "copy" . typesCopyFunctionType) in if isTypeGeneric concreteStructTy
(filter (isManaged typeEnv) (map snd memberPairs))) 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 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 Data.Foldable (foldlM)
import Types
import Obj
import Util
import Lookup
import TypeError
import Info import Info
import Lookup
import Obj
import TypeError
import Types
import Util
-- | Used for calling back to the 'eval' function in Eval.hs -- | Used for calling back to the 'eval' function in Eval.hs
type DynamicEvaluator = Context -> XObj -> IO (Context, Either EvalError XObj) 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! -- | 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 :: DynamicEvaluator -> Context -> XObj -> IO (Context, Either EvalError XObj)
expandAll eval ctx root = expandAll eval ctx root =
do (ctx', fullyExpanded) <- expandAllInternal root do
pure (ctx', fmap setNewIdentifiers fullyExpanded) (ctx', fullyExpanded) <- expandAllInternal root
where expandAllInternal xobj = pure (ctx', fmap setNewIdentifiers fullyExpanded)
do (newCtx, expansionResult) <- expand eval ctx xobj where
case expansionResult of expandAllInternal xobj =
Right expanded -> if expanded == xobj do
then pure (newCtx, Right expanded) (newCtx, expansionResult) <- expand eval ctx xobj
else expandAll eval newCtx expanded case expansionResult of
err -> pure (newCtx, err) 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 -- | Macro expansion of a single form
expand :: DynamicEvaluator -> Context -> XObj -> IO (Context, Either EvalError XObj) expand :: DynamicEvaluator -> Context -> XObj -> IO (Context, Either EvalError XObj)
expand eval ctx xobj = expand eval ctx xobj =
case xobjObj xobj of case xobjObj xobj of
--case obj (trace ("Expand: " ++ pretty xobj) xobj) of --case obj (trace ("Expand: " ++ pretty xobj) xobj) of
Lst _ -> expandList xobj Lst _ -> expandList xobj
Arr _ -> expandArray xobj Arr _ -> expandArray xobj
Sym _ _ -> expandSymbol xobj Sym _ _ -> expandSymbol xobj
_ -> pure (ctx, Right xobj) _ -> pure (ctx, Right xobj)
where where
expandList :: XObj -> IO (Context, Either EvalError XObj) expandList :: XObj -> IO (Context, Either EvalError XObj)
expandList (XObj (Lst xobjs) i t) = do expandList (XObj (Lst xobjs) i t) = do
@ -47,111 +49,180 @@ expand eval ctx xobj =
XObj (Deftemplate _) _ _ : _ -> pure (ctx, Right xobj) XObj (Deftemplate _) _ _ : _ -> pure (ctx, Right xobj)
XObj (Defalias _) _ _ : _ -> pure (ctx, Right xobj) XObj (Defalias _) _ _ : _ -> pure (ctx, Right xobj)
[defnExpr@(XObj (Defn _) _ _), name, args, body] -> [defnExpr@(XObj (Defn _) _ _), name, args, body] ->
do (ctx', expandedBody) <- expand eval ctx body do
pure (ctx', do okBody <- expandedBody (ctx', expandedBody) <- expand eval ctx body
Right (XObj (Lst [defnExpr, name, args, okBody]) i t)) pure
( ctx',
do
okBody <- expandedBody
Right (XObj (Lst [defnExpr, name, args, okBody]) i t)
)
[defExpr@(XObj Def _ _), name, expr] -> [defExpr@(XObj Def _ _), name, expr] ->
do (ctx', expandedExpr) <- expand eval ctx expr do
pure (ctx', do okExpr <- expandedExpr (ctx', expandedExpr) <- expand eval ctx expr
Right (XObj (Lst [defExpr, name, okExpr]) i t)) pure
( ctx',
do
okExpr <- expandedExpr
Right (XObj (Lst [defExpr, name, okExpr]) i t)
)
[theExpr@(XObj The _ _), typeXObj, value] -> [theExpr@(XObj The _ _), typeXObj, value] ->
do (ctx', expandedValue) <- expand eval ctx value do
pure (ctx', do okValue <- expandedValue (ctx', expandedValue) <- expand eval ctx value
Right (XObj (Lst [theExpr, typeXObj, okValue]) i t)) pure
( ctx',
do
okValue <- expandedValue
Right (XObj (Lst [theExpr, typeXObj, okValue]) i t)
)
(XObj The _ _ : _) -> (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] -> [ifExpr@(XObj If _ _), condition, trueBranch, falseBranch] ->
do (ctx', expandedCondition) <- expand eval ctx condition do
(ctx'', expandedTrueBranch) <- expand eval ctx' trueBranch (ctx', expandedCondition) <- expand eval ctx condition
(nct, expandedFalseBranch) <- expand eval ctx'' falseBranch (ctx'', expandedTrueBranch) <- expand eval ctx' trueBranch
pure (nct, do okCondition <- expandedCondition (nct, expandedFalseBranch) <- expand eval ctx'' falseBranch
okTrueBranch <- expandedTrueBranch pure
okFalseBranch <- expandedFalseBranch ( nct,
-- This is a HACK so that each branch of the if statement do
-- has a "safe place" (= a do-expression with just one element) okCondition <- expandedCondition
-- where it can store info about its deleters. Without this, okTrueBranch <- expandedTrueBranch
-- An if statement with let-expression inside will duplicate okFalseBranch <- expandedFalseBranch
-- the calls to Delete when emitting code. -- This is a HACK so that each branch of the if statement
let wrappedTrue = -- has a "safe place" (= a do-expression with just one element)
case okTrueBranch of -- where it can store info about its deleters. Without this,
XObj (Lst (XObj Do _ _ : _)) _ _ -> okTrueBranch -- Has a do-expression already -- An if statement with let-expression inside will duplicate
_ -> XObj (Lst [XObj Do Nothing Nothing, okTrueBranch]) (xobjInfo okTrueBranch) Nothing -- the calls to Delete when emitting code.
wrappedFalse = let wrappedTrue =
case okFalseBranch of case okTrueBranch of
XObj (Lst (XObj Do _ _ : _)) _ _ -> okFalseBranch -- Has a do-expression already XObj (Lst (XObj Do _ _ : _)) _ _ -> okTrueBranch -- Has a do-expression already
_ -> XObj (Lst [XObj Do Nothing Nothing, okFalseBranch]) (xobjInfo okFalseBranch) Nothing _ -> XObj (Lst [XObj Do Nothing Nothing, okTrueBranch]) (xobjInfo okTrueBranch) Nothing
wrappedFalse =
Right (XObj (Lst [ifExpr, okCondition, wrappedTrue, wrappedFalse]) i t)) 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] -> [letExpr@(XObj Let _ _), XObj (Arr bindings) bindi bindt, body] ->
if even (length bindings) if even (length bindings)
then do (ctx', bind) <- foldlM successiveExpandLR (ctx, Right []) (pairwise bindings) then do
(newCtx, expandedBody) <- expand eval ctx' body (ctx', bind) <- foldlM successiveExpandLR (ctx, Right []) (pairwise bindings)
pure (newCtx, do okBindings <- bind (newCtx, expandedBody) <- expand eval ctx' body
okBody <- expandedBody pure
Right (XObj (Lst [letExpr, XObj (Arr (concat okBindings)) bindi bindt, okBody]) i t)) ( newCtx,
else pure (evalError ctx ( do
"I ecountered an odd number of forms inside a `let` (`" ++ okBindings <- bind
pretty xobj ++ "`)") (xobjInfo xobj)) 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) matchExpr@(XObj (Match _) _ _) : (expr : rest)
| null 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) -> | even (length rest) ->
do (ctx', expandedExpr) <- expand eval ctx expr do
(newCtx, expandedPairs) <- foldlM successiveExpandLR (ctx', Right []) (pairwise rest) (ctx', expandedExpr) <- expand eval ctx expr
pure (newCtx, do okExpandedExpr <- expandedExpr (newCtx, expandedPairs) <- foldlM successiveExpandLR (ctx', Right []) (pairwise rest)
okExpandedPairs <- expandedPairs pure
Right (XObj (Lst (matchExpr : okExpandedExpr : (concat okExpandedPairs))) i t)) ( newCtx,
| otherwise -> pure (evalError ctx do
"I encountered an odd number of forms inside a `match`" (xobjInfo xobj)) 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 -> doExpr@(XObj Do _ _) : expressions ->
do (newCtx, expandedExpressions) <- foldlM successiveExpand (ctx, Right []) expressions do
pure (newCtx, do okExpressions <- expandedExpressions (newCtx, expandedExpressions) <- foldlM successiveExpand (ctx, Right []) expressions
Right (XObj (Lst (doExpr : okExpressions)) i t)) pure
( newCtx,
do
okExpressions <- expandedExpressions
Right (XObj (Lst (doExpr : okExpressions)) i t)
)
[withExpr@(XObj With _ _), pathExpr@(XObj (Sym _ _) _ _), expression] -> [withExpr@(XObj With _ _), pathExpr@(XObj (Sym _ _) _ _), expression] ->
do (newCtx, expandedExpression) <- expand eval ctx expression do
pure (newCtx, do okExpression <- expandedExpression (newCtx, expandedExpression) <- expand eval ctx expression
Right (XObj (Lst [withExpr, pathExpr , okExpression]) i t)) -- Replace the with-expression with just the expression! pure
( newCtx,
do
okExpression <- expandedExpression
Right (XObj (Lst [withExpr, pathExpr, okExpression]) i t) -- Replace the with-expression with just the expression!
)
[(XObj With _ _), _, _] -> [(XObj With _ _), _, _] ->
pure (evalError ctx ("I encountered the value `" ++ pretty xobj ++ pure
"` inside a `with` at " ++ prettyInfoFromXObj xobj ++ ( evalError
".\n\n`with` accepts only symbols.") Nothing) ctx
( "I encountered the value `" ++ pretty xobj
++ "` inside a `with` at "
++ prettyInfoFromXObj xobj
++ ".\n\n`with` accepts only symbols."
)
Nothing
)
XObj With _ _ : _ -> XObj With _ _ : _ ->
pure (evalError ctx ( pure
"I encountered multiple forms inside a `with` at " ++ ( evalError
prettyInfoFromXObj xobj ++ ctx
".\n\n`with` accepts only one expression, except at the top level.") Nothing) ( "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 -> XObj (Mod modEnv) _ _ : args ->
let pathToModule = pathToEnv modEnv let pathToModule = pathToEnv modEnv
implicitInit = XObj (Sym (SymPath pathToModule "init") Symbol) i t implicitInit = XObj (Sym (SymPath pathToModule "init") Symbol) i t
in expand eval ctx (XObj (Lst (implicitInit : args)) (xobjInfo xobj) (xobjTy xobj)) in expand eval ctx (XObj (Lst (implicitInit : args)) (xobjInfo xobj) (xobjTy xobj))
f:args -> f : args ->
do (_, expandedF) <- expand eval ctx f do
(ctx'', expandedArgs) <- foldlM successiveExpand (ctx, Right []) args (_, expandedF) <- expand eval ctx f
case expandedF of (ctx'', expandedArgs) <- foldlM successiveExpand (ctx, Right []) args
Right (XObj (Lst [XObj Dynamic _ _, _, XObj (Arr _) _ _, _]) _ _) -> case expandedF of
--trace ("Found dynamic: " ++ pretty xobj) Right (XObj (Lst [XObj Dynamic _ _, _, XObj (Arr _) _ _, _]) _ _) ->
eval ctx'' xobj --trace ("Found dynamic: " ++ pretty xobj)
Right (XObj (Lst [XObj Macro _ _, _, XObj (Arr _) _ _, _]) _ _) -> eval ctx'' xobj
--trace ("Found macro: " ++ pretty xobj ++ " at " ++ prettyInfoFromXObj xobj) Right (XObj (Lst [XObj Macro _ _, _, XObj (Arr _) _ _, _]) _ _) ->
eval ctx'' xobj --trace ("Found macro: " ++ pretty xobj ++ " at " ++ prettyInfoFromXObj xobj)
Right (XObj (Lst [XObj (Command callback) _ _, _]) _ _) -> eval ctx'' xobj
getCommand callback ctx args Right (XObj (Lst [XObj (Command callback) _ _, _]) _ _) ->
Right _ -> getCommand callback ctx args
pure (ctx'', do okF <- expandedF Right _ ->
okArgs <- expandedArgs pure
Right (XObj (Lst (okF : okArgs)) i t)) ( ctx'',
Left err -> pure (ctx'', Left err) 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." expandList _ = error "Can't expand non-list in expandList."
expandArray :: XObj -> IO (Context, Either EvalError XObj) expandArray :: XObj -> IO (Context, Either EvalError XObj)
expandArray (XObj (Arr xobjs) i t) = expandArray (XObj (Arr xobjs) i t) =
do (newCtx, evaledXObjs) <- foldlM successiveExpand (ctx, Right []) xobjs do
pure (newCtx, do okXObjs <- evaledXObjs (newCtx, evaledXObjs) <- foldlM successiveExpand (ctx, Right []) xobjs
Right (XObj (Arr okXObjs) i t)) pure
( newCtx,
do
okXObjs <- evaledXObjs
Right (XObj (Arr okXObjs) i t)
)
expandArray _ = error "Can't expand non-array in expandArray." expandArray _ = error "Can't expand non-array in expandArray."
expandSymbol :: XObj -> IO (Context, Either EvalError XObj) expandSymbol :: XObj -> IO (Context, Either EvalError XObj)
expandSymbol sym@(XObj (Sym path _) _ _) = expandSymbol sym@(XObj (Sym path _) _ _) =
case lookupInEnv path (contextEnv ctx) of 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 (XObj (Lst (XObj (Defalias _) _ _ : _)) _ _)) -> isPrivate meta xobj
Just (_, Binder meta found) -> isPrivate meta found -- use the found value 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 Nothing -> pure (ctx, Right xobj) -- symbols that are not found are left as-is
where where
isPrivate m x = pure $ if metaIsTrue m "private" isPrivate m x =
then evalError ctx ("The binding: " ++ pretty sym ++ " is private; it may only be used within the module that defines it.") (xobjInfo sym) pure $
else (ctx, Right x) 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) expandSymbol _ = pure (evalError ctx "Can't expand non-symbol in expandSymbol." Nothing)
successiveExpand (ctx', acc) e = successiveExpand (ctx', acc) e =
case acc of case acc of
Left _ -> pure (ctx', acc) Left _ -> pure (ctx', acc)
@ -177,7 +249,6 @@ expand eval ctx xobj =
pure $ case expanded of pure $ case expanded of
Right err -> (newCtx, Right (lst ++ [err])) Right err -> (newCtx, Right (lst ++ [err]))
Left err -> (newCtx, Left err) Left err -> (newCtx, Left err)
successiveExpandLR (ctx', acc) (l, r) = successiveExpandLR (ctx', acc) (l, r) =
case acc of case acc of
Left _ -> pure (ctx', acc) Left _ -> pure (ctx', acc)
@ -189,10 +260,12 @@ expand eval ctx xobj =
-- | Replace all the infoIdentifier:s on all nested XObj:s -- | Replace all the infoIdentifier:s on all nested XObj:s
setNewIdentifiers :: XObj -> XObj setNewIdentifiers :: XObj -> XObj
setNewIdentifiers root = let final = evalState (visit root) 0 setNewIdentifiers root =
in final let final = evalState (visit root) 0
--trace ("ROOT: " ++ prettyTyped root ++ "FINAL: " ++ prettyTyped final) final in final
where where
--trace ("ROOT: " ++ prettyTyped root ++ "FINAL: " ++ prettyTyped final) final
visit :: XObj -> State Int XObj visit :: XObj -> State Int XObj
visit xobj = visit xobj =
case xobjObj xobj of case xobjObj xobj of
@ -200,35 +273,35 @@ setNewIdentifiers root = let final = evalState (visit root) 0
(Arr _) -> visitArray xobj (Arr _) -> visitArray xobj
(StaticArr _) -> visitStaticArray xobj (StaticArr _) -> visitStaticArray xobj
_ -> bumpAndSet xobj _ -> bumpAndSet xobj
visitList :: XObj -> State Int XObj visitList :: XObj -> State Int XObj
visitList (XObj (Lst xobjs) i t) = visitList (XObj (Lst xobjs) i t) =
do visited <- mapM visit xobjs do
let xobj' = XObj (Lst visited) i t visited <- mapM visit xobjs
bumpAndSet xobj' let xobj' = XObj (Lst visited) i t
bumpAndSet xobj'
visitList _ = error "The function 'visitList' only accepts XObjs with lists in them." visitList _ = error "The function 'visitList' only accepts XObjs with lists in them."
visitArray :: XObj -> State Int XObj visitArray :: XObj -> State Int XObj
visitArray (XObj (Arr xobjs) i t) = visitArray (XObj (Arr xobjs) i t) =
do visited <- mapM visit xobjs do
let xobj' = XObj (Arr visited) i t visited <- mapM visit xobjs
bumpAndSet xobj' let xobj' = XObj (Arr visited) i t
bumpAndSet xobj'
visitArray _ = error "The function 'visitArray' only accepts XObjs with arrays in them." visitArray _ = error "The function 'visitArray' only accepts XObjs with arrays in them."
visitStaticArray :: XObj -> State Int XObj visitStaticArray :: XObj -> State Int XObj
visitStaticArray (XObj (StaticArr xobjs) i t) = visitStaticArray (XObj (StaticArr xobjs) i t) =
do visited <- mapM visit xobjs do
let xobj' = XObj (StaticArr visited) i t visited <- mapM visit xobjs
bumpAndSet xobj' let xobj' = XObj (StaticArr visited) i t
bumpAndSet xobj'
visitStaticArray _ = error "The function 'visitStaticArray' only accepts XObjs with arrays in them." visitStaticArray _ = error "The function 'visitStaticArray' only accepts XObjs with arrays in them."
bumpAndSet :: XObj -> State Int XObj bumpAndSet :: XObj -> State Int XObj
bumpAndSet xobj = bumpAndSet xobj =
do counter <- get do
put (counter + 1) counter <- get
pure $ case xobjInfo xobj of put (counter + 1)
Just i -> (xobj { xobjInfo = Just (i { infoIdentifier = counter })}) pure $ case xobjInfo xobj of
Nothing -> xobj Just i -> (xobj {xobjInfo = Just (i {infoIdentifier = counter})})
Nothing -> xobj
-- | Replaces the file, line and column info on an XObj an all its children. -- | Replaces the file, line and column info on an XObj an all its children.
replaceSourceInfo :: FilePath -> Int -> Int -> XObj -> XObj replaceSourceInfo :: FilePath -> Int -> Int -> XObj -> XObj
@ -240,29 +313,34 @@ replaceSourceInfo newFile newLine newColumn root = visit root
(Lst _) -> visitList xobj (Lst _) -> visitList xobj
(Arr _) -> visitArray xobj (Arr _) -> visitArray xobj
_ -> setNewInfo xobj _ -> setNewInfo xobj
visitList :: XObj -> XObj visitList :: XObj -> XObj
visitList (XObj (Lst xobjs) i t) = visitList (XObj (Lst xobjs) i t) =
setNewInfo (XObj (Lst (map visit xobjs)) i t) setNewInfo (XObj (Lst (map visit xobjs)) i t)
visitList _ = visitList _ =
error "The function 'visitList' only accepts XObjs with lists in them." error "The function 'visitList' only accepts XObjs with lists in them."
visitArray :: XObj -> XObj visitArray :: XObj -> XObj
visitArray (XObj (Arr xobjs) i t) = visitArray (XObj (Arr xobjs) i t) =
setNewInfo (XObj (Arr (map visit xobjs)) i t) setNewInfo (XObj (Arr (map visit xobjs)) i t)
visitArray _ = error "The function 'visitArray' only accepts XObjs with arrays in them." visitArray _ = error "The function 'visitArray' only accepts XObjs with arrays in them."
setNewInfo :: XObj -> XObj setNewInfo :: XObj -> XObj
setNewInfo xobj = setNewInfo xobj =
case xobjInfo xobj of case xobjInfo xobj of
Just i -> (xobj { xobjInfo = Just (i { infoFile = newFile Just i ->
, infoLine = newLine ( xobj
, infoColumn = newColumn { xobjInfo =
})}) Just
( i
{ infoFile = newFile,
infoLine = newLine,
infoColumn = newColumn
}
)
}
)
Nothing -> xobj Nothing -> xobj
replaceSourceInfoOnXObj :: Maybe Info -> XObj -> XObj replaceSourceInfoOnXObj :: Maybe Info -> XObj -> XObj
replaceSourceInfoOnXObj newInfo xobj = replaceSourceInfoOnXObj newInfo xobj =
case newInfo of 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 Nothing -> xobj

605
src/GenerateConstraints.hs
View File

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

65
src/Infer.hs
View File

@ -1,20 +1,22 @@
module Infer (annotate module Infer
,initialTypes ( annotate,
,genConstraints initialTypes,
,assignTypes genConstraints,
,concretizeXObj assignTypes,
,manageMemory concretizeXObj,
,depsOfPolymorphicFunction manageMemory,
) where depsOfPolymorphicFunction,
)
where
import Obj
import Constraints
import Types
import TypeError
import InitialTypes
import AssignTypes import AssignTypes
import GenerateConstraints
import Concretize 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. -- | 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. -- | 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. -- | 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 -> Env -> XObj -> Maybe (Ty, XObj) -> Either TypeError (XObj, [XObj])
annotate typeEnv globalEnv xobj rootSig = annotate typeEnv globalEnv xobj rootSig =
do initiated <- initialTypes typeEnv globalEnv xobj do
(annotated, dependencies) <- annotateUntilDone typeEnv globalEnv initiated rootSig [] 100 initiated <- initialTypes typeEnv globalEnv xobj
(final, deleteDeps) <- manageMemory typeEnv globalEnv annotated (annotated, dependencies) <- annotateUntilDone typeEnv globalEnv initiated rootSig [] 100
finalWithNiceTypes <- beautifyTypeVariables final (final, deleteDeps) <- manageMemory typeEnv globalEnv annotated
pure (finalWithNiceTypes, dependencies ++ deleteDeps) finalWithNiceTypes <- beautifyTypeVariables final
pure (finalWithNiceTypes, dependencies ++ deleteDeps)
-- | Call the 'annotateOne' function until nothing changes -- | Call the 'annotateOne' function until nothing changes
annotateUntilDone :: TypeEnv -> Env -> XObj -> Maybe (Ty, XObj) -> [XObj] -> Int -> Either TypeError (XObj, [XObj]) annotateUntilDone :: TypeEnv -> Env -> XObj -> Maybe (Ty, XObj) -> [XObj] -> Int -> Either TypeError (XObj, [XObj])
annotateUntilDone typeEnv globalEnv xobj rootSig deps limiter = annotateUntilDone typeEnv globalEnv xobj rootSig deps limiter =
if limiter <= 0 if limiter <= 0
then Left (TooManyAnnotateCalls xobj) then Left (TooManyAnnotateCalls xobj)
else do (xobj', deps') <- annotateOne typeEnv globalEnv xobj rootSig True else do
let newDeps = deps ++ deps' (xobj', deps') <- annotateOne typeEnv globalEnv xobj rootSig True
if xobj == xobj' -- Is it the same? let newDeps = deps ++ deps'
then pure (xobj', newDeps) if xobj == xobj' -- Is it the same?
else annotateUntilDone typeEnv globalEnv xobj' rootSig newDeps (limiter - 1) 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. -- | Performs ONE step of annotation. The 'annotate' function will call this function several times.
-- | TODO: Remove the allowAmbiguity flag? -- | TODO: Remove the allowAmbiguity flag?
@ -52,9 +56,12 @@ annotateOne typeEnv env xobj rootSig allowAmbiguity = do
solveConstraintsAndConvertErrorIfNeeded :: [Constraint] -> Either TypeError TypeMappings solveConstraintsAndConvertErrorIfNeeded :: [Constraint] -> Either TypeError TypeMappings
solveConstraintsAndConvertErrorIfNeeded constraints = solveConstraintsAndConvertErrorIfNeeded constraints =
case solve constraints of case solve constraints of
Left failure@(UnificationFailure _ _) -> Left (UnificationFailed Left failure@(UnificationFailure _ _) ->
(unificationFailure failure) Left
(unificationMappings failure) ( UnificationFailed
constraints) (unificationFailure failure)
(unificationMappings failure)
constraints
)
Left (Holes holes) -> Left (HolesFound holes) Left (Holes holes) -> Left (HolesFound holes)
Right ok -> Right ok 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 -- | Module Info defines data types and functions for reporting details about
-- the Carp forms in a source file. -- the Carp forms in a source file.
module Info (Info(..), module Info
Deleter(..), ( Info (..),
FilePathPrintLength(..), Deleter (..),
dummyInfo, FilePathPrintLength (..),
getInfo, dummyInfo,
prettyInfo, getInfo,
freshVar, prettyInfo,
machineReadableInfo, freshVar,
makeTypeVariableNameFromInfo) where machineReadableInfo,
makeTypeVariableNameFromInfo,
)
where
import qualified Data.Set as Set import qualified Data.Set as Set
import Path (takeFileName) import Path (takeFileName)
import SymPath import SymPath
-- | Information about where the Obj originated from. -- | Information about where the Obj originated from.
data Info = Info { infoLine :: Int data Info
, infoColumn :: Int = Info
, infoFile :: String { infoLine :: Int,
, infoDelete :: Set.Set Deleter infoColumn :: Int,
, infoIdentifier :: Int infoFile :: String,
} deriving (Show, Eq, Ord) infoDelete :: Set.Set Deleter,
infoIdentifier :: Int
}
deriving (Show, Eq, Ord)
-- TODO: The name 'deleter' for these things are really confusing! -- TODO: The name 'deleter' for these things are really confusing!
-- | Designates the deleter function for a Carp object. -- | Designates the deleter function for a Carp object.
data Deleter = ProperDeleter { deleterPath :: SymPath data Deleter
, deleterVariable :: String = ProperDeleter
} { deleterPath :: SymPath,
-- used for external types with no delete function deleterVariable :: String
| FakeDeleter { deleterVariable :: String }
} | -- used for external types with no delete function
-- used by primitive types (i.e. Int) to signify that the variable is alive FakeDeleter
| PrimDeleter { aliveVariable :: String { deleterVariable :: String
} }
| RefDeleter { refVariable :: String | -- used by primitive types (i.e. Int) to signify that the variable is alive
} PrimDeleter
deriving (Eq, Ord) { aliveVariable :: String
}
| RefDeleter
{ refVariable :: String
}
deriving (Eq, Ord)
instance Show Deleter where instance Show Deleter where
show (ProperDeleter path var) = "(ProperDel " ++ show path ++ " " ++ show var ++ ")" 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 -- | Whether or not the full path of a source file or a short path should be
-- printed. -- printed.
data FilePathPrintLength = FullPath data FilePathPrintLength
| ShortPath deriving Eq = FullPath
| ShortPath
deriving (Eq)
instance Show FilePathPrintLength where instance Show FilePathPrintLength where
show FullPath = "full" show FullPath = "full"
@ -66,9 +80,11 @@ getInfo i = (infoLine i, infoColumn i, infoFile i)
prettyInfo :: Info -> String prettyInfo :: Info -> String
prettyInfo i = prettyInfo i =
let (line, column, file) = getInfo i let (line, column, file) = getInfo i
in (if line > -1 then "line " ++ show line else "unknown line") ++ ", " ++ in (if line > -1 then "line " ++ show line else "unknown line") ++ ", "
(if column > -1 then "column " ++ show column else "unknown column") ++ ++ (if column > -1 then "column " ++ show column else "unknown column")
" in '" ++ file ++ "'" ++ " in '"
++ file
++ "'"
-- TODO: change name of this function -- TODO: change name of this function
freshVar :: Info -> String freshVar :: Info -> String
@ -79,9 +95,9 @@ machineReadableInfo :: FilePathPrintLength -> Info -> String
machineReadableInfo filePathPrintLength i = machineReadableInfo filePathPrintLength i =
let (line, column, file) = getInfo i let (line, column, file) = getInfo i
file' = case filePathPrintLength of file' = case filePathPrintLength of
FullPath -> file FullPath -> file
ShortPath -> takeFileName file ShortPath -> takeFileName file
in file' ++ ":" ++ show line ++ ":" ++ show column in file' ++ ":" ++ show line ++ ":" ++ show column
-- | Use an Info to generate a type variable name. -- | Use an Info to generate a type variable name.
makeTypeVariableNameFromInfo :: Maybe Info -> String makeTypeVariableNameFromInfo :: Maybe Info -> String

636
src/InitialTypes.hs
View File

@ -2,20 +2,20 @@ module InitialTypes where
import Control.Monad.State import Control.Monad.State
import qualified Data.Map as Map import qualified Data.Map as Map
import Types
import Obj
import Util
import TypeError
import Lookup
import Info import Info
import Lookup
import Obj
import TypeError
import Types
import Util
-- | Create a fresh type variable (eg. 'VarTy t0', 'VarTy t1', etc...) -- | Create a fresh type variable (eg. 'VarTy t0', 'VarTy t1', etc...)
genVarTyWithPrefix :: String -> State Integer Ty genVarTyWithPrefix :: String -> State Integer Ty
genVarTyWithPrefix prefix = genVarTyWithPrefix prefix =
do x <- get do
put (x + 1) x <- get
pure (VarTy (prefix ++ show x)) put (x + 1)
pure (VarTy (prefix ++ show x))
genVarTy :: State Integer Ty genVarTy :: State Integer Ty
genVarTy = genVarTyWithPrefix "t" genVarTy = genVarTyWithPrefix "t"
@ -29,34 +29,38 @@ genVarTys n = replicateM n genVarTy
-- Example: (t0, t1, t1) -> t0 -- Example: (t0, t1, t1) -> t0
-- becomes: (r2, r3, r3) -> r2 -- becomes: (r2, r3, r3) -> r2
renameVarTys :: Ty -> State Integer Ty renameVarTys :: Ty -> State Integer Ty
renameVarTys rootType = do n <- get renameVarTys rootType = do
let (result, (n', _)) = runState (rename rootType) (n, Map.empty) n <- get
put n' let (result, (n', _)) = runState (rename rootType) (n, Map.empty)
pure result put n'
pure result
where where
rename :: Ty -> State (Integer, Map.Map String Ty) Ty rename :: Ty -> State (Integer, Map.Map String Ty) Ty
rename (FuncTy argTys retTy ltTy) = do ltTy' <- rename ltTy rename (FuncTy argTys retTy ltTy) = do
argTys' <- mapM rename argTys ltTy' <- rename ltTy
retTy' <- rename retTy argTys' <- mapM rename argTys
pure (FuncTy argTys' retTy' ltTy') retTy' <- rename retTy
rename (VarTy v) = do (n, mappings) <- get pure (FuncTy argTys' retTy' ltTy')
case Map.lookup v mappings of rename (VarTy v) = do
Just found -> pure found (n, mappings) <- get
Nothing -> do let varTy = VarTy ("r" ++ show n) case Map.lookup v mappings of
newMappings = Map.insert v varTy mappings Just found -> pure found
put (n + 1, newMappings) Nothing -> do
pure varTy let varTy = VarTy ("r" ++ show n)
rename (StructTy name tyArgs) = do tyArgs' <- mapM rename tyArgs newMappings = Map.insert v varTy mappings
name' <- rename name put (n + 1, newMappings)
pure (StructTy name' tyArgs') pure varTy
rename (StructTy name tyArgs) = do
rename (PointerTy x) = do x' <- rename x tyArgs' <- mapM rename tyArgs
pure (PointerTy x') name' <- rename name
pure (StructTy name' tyArgs')
rename (RefTy x lt) = do x' <- rename x rename (PointerTy x) = do
lt' <- rename lt x' <- rename x
pure (RefTy x' lt') pure (PointerTy x')
rename (RefTy x lt) = do
x' <- rename x
lt' <- rename lt
pure (RefTy x' lt')
rename x = pure x rename x = pure x
-- | Adds initial types to a s-expression and all its sub-nodes. -- | 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 where
visit :: Env -> XObj -> State Integer (Either TypeError XObj) visit :: Env -> XObj -> State Integer (Either TypeError XObj)
visit env xobj = case xobjObj xobj of visit env xobj = case xobjObj xobj of
(Num t _) -> pure (Right (xobj { xobjTy = Just t })) (Num t _) -> pure (Right (xobj {xobjTy = Just t}))
(Bol _) -> pure (Right (xobj { xobjTy = Just BoolTy })) (Bol _) -> pure (Right (xobj {xobjTy = Just BoolTy}))
(Str _) -> do lt <- genVarTy (Str _) -> do
pure (Right (xobj { xobjTy = Just (RefTy StringTy lt) })) lt <- genVarTy
(Pattern _) -> do lt <- genVarTy pure (Right (xobj {xobjTy = Just (RefTy StringTy lt)}))
pure (Right (xobj { xobjTy = Just (RefTy PatternTy lt) })) (Pattern _) -> do
(Chr _) -> pure (Right (xobj { xobjTy = Just CharTy })) lt <- genVarTy
Break -> pure (Right (xobj { xobjTy = Just (FuncTy [] UnitTy StaticLifetimeTy)})) pure (Right (xobj {xobjTy = Just (RefTy PatternTy lt)}))
(Command _) -> pure (Right (xobj { xobjTy = Just DynamicTy })) (Chr _) -> pure (Right (xobj {xobjTy = Just CharTy}))
(Lst _) -> visitList env xobj Break -> pure (Right (xobj {xobjTy = Just (FuncTy [] UnitTy StaticLifetimeTy)}))
(Arr _) -> visitArray env xobj (Command _) -> pure (Right (xobj {xobjTy = Just DynamicTy}))
(StaticArr _) -> visitStaticArray env xobj (Lst _) -> visitList env xobj
(Dict _) -> visitDictionary env xobj (Arr _) -> visitArray env xobj
(Sym symPath _) -> visitSymbol env xobj symPath (StaticArr _) -> visitStaticArray env xobj
(MultiSym _ paths) -> visitMultiSym env xobj paths (Dict _) -> visitDictionary env xobj
(InterfaceSym _) -> visitInterfaceSym env xobj (Sym symPath _) -> visitSymbol env xobj symPath
e@(Defn _) -> pure (Left (InvalidObj e xobj)) (MultiSym _ paths) -> visitMultiSym env xobj paths
Def -> pure (Left (InvalidObj Def xobj)) (InterfaceSym _) -> visitInterfaceSym env xobj
DefDynamic -> pure (Left (InvalidObj DefDynamic xobj)) e@(Defn _) -> pure (Left (InvalidObj e xobj))
e@(Fn _ _) -> pure (Left (InvalidObj e xobj)) Def -> pure (Left (InvalidObj Def xobj))
Let -> pure (Left (InvalidObj Let xobj)) DefDynamic -> pure (Left (InvalidObj DefDynamic xobj))
If -> pure (Left (InvalidObj If xobj)) e@(Fn _ _) -> pure (Left (InvalidObj e xobj))
While -> pure (Left (InvalidObj While xobj)) Let -> pure (Left (InvalidObj Let xobj))
Do -> pure (Left (InvalidObj Do xobj)) If -> pure (Left (InvalidObj If xobj))
(Mod _) -> pure (Left (InvalidObj If xobj)) While -> pure (Left (InvalidObj While xobj))
e@(Deftype _) -> pure (Left (InvalidObj e xobj)) Do -> pure (Left (InvalidObj Do xobj))
e@(External _) -> pure (Left (InvalidObj e xobj)) (Mod _) -> pure (Left (InvalidObj If xobj))
e@(ExternalType _) -> pure (Left (InvalidObj e xobj)) e@(Deftype _) -> pure (Left (InvalidObj e xobj))
e@(Deftemplate _) -> pure (Left (InvalidObj e xobj)) e@(External _) -> pure (Left (InvalidObj e xobj))
e@(Instantiate _) -> pure (Left (InvalidObj e xobj)) e@(ExternalType _) -> pure (Left (InvalidObj e xobj))
e@(Defalias _) -> pure (Left (InvalidObj e xobj)) e@(Deftemplate _) -> pure (Left (InvalidObj e xobj))
Address -> pure (Left (InvalidObj Address xobj)) e@(Instantiate _) -> pure (Left (InvalidObj e xobj))
SetBang -> pure (Left (InvalidObj SetBang xobj)) e@(Defalias _) -> pure (Left (InvalidObj e xobj))
Macro -> pure (Left (InvalidObj Macro xobj)) Address -> pure (Left (InvalidObj Address xobj))
The -> pure (Left (InvalidObj The xobj)) SetBang -> pure (Left (InvalidObj SetBang xobj))
Dynamic -> pure (Left (InvalidObj Dynamic xobj)) Macro -> pure (Left (InvalidObj Macro xobj))
Ref -> pure (Left (InvalidObj Ref xobj)) The -> pure (Left (InvalidObj The xobj))
Deref -> pure (Left (InvalidObj Deref xobj)) Dynamic -> pure (Left (InvalidObj Dynamic xobj))
With -> pure (Left (InvalidObj With xobj)) Ref -> pure (Left (InvalidObj Ref xobj))
-- catchall case for exhaustive patterns Deref -> pure (Left (InvalidObj Deref xobj))
unknown -> pure (Left (InvalidObj unknown 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 :: Env -> XObj -> SymPath -> State Integer (Either TypeError XObj)
visitSymbol _ xobj@(XObj (Sym _ LookupRecursive) _ _) _ = visitSymbol _ xobj@(XObj (Sym _ LookupRecursive) _ _) _ =
-- Recursive lookups are left untouched (this avoids problems with looking up the thing they're referring to) -- Recursive lookups are left untouched (this avoids problems with looking up the thing they're referring to)
do freshTy <- genVarTy do
pure (Right xobj { xobjTy = Just freshTy }) freshTy <- genVarTy
pure (Right xobj {xobjTy = Just freshTy})
visitSymbol env xobj symPath = visitSymbol env xobj symPath =
case symPath of case symPath of
-- Symbols with leading ? are 'holes'. -- 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)) SymPath _ (':' : _) -> pure (Left (LeadingColon xobj))
_ -> _ ->
case lookupInEnv symPath env of case lookupInEnv symPath env of
Just (foundEnv, binder) -> Just (foundEnv, binder) ->
case xobjTy (binderXObj binder) of case xobjTy (binderXObj binder) of
-- Don't rename internal symbols like parameters etc! -- Don't rename internal symbols like parameters etc!
Just theType | envIsExternal foundEnv -> do renamed <- renameVarTys theType Just theType
pure (Right (xobj { xobjTy = Just renamed })) | envIsExternal foundEnv -> do
| otherwise -> pure (Right (xobj { xobjTy = Just theType })) 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 (SymbolMissingType xobj foundEnv))
Nothing -> pure (Left (SymbolNotDefined symPath xobj env)) -- Gives the error message "Trying to refer to an undefined symbol ..." 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 :: Env -> XObj -> [SymPath] -> State Integer (Either TypeError XObj)
visitMultiSym _ xobj@(XObj (MultiSym _ _) _ _) _ = visitMultiSym _ xobj@(XObj (MultiSym _ _) _ _) _ =
do freshTy <- genVarTy do
pure (Right xobj { xobjTy = Just freshTy }) freshTy <- genVarTy
pure (Right xobj {xobjTy = Just freshTy})
visitInterfaceSym :: Env -> XObj -> State Integer (Either TypeError XObj) visitInterfaceSym :: Env -> XObj -> State Integer (Either TypeError XObj)
visitInterfaceSym _ xobj@(XObj (InterfaceSym name) _ _) = visitInterfaceSym _ xobj@(XObj (InterfaceSym name) _ _) =
do freshTy <- case lookupInEnv (SymPath [] name) (getTypeEnv typeEnv) of do
Just (_, Binder _ (XObj (Lst [XObj (Interface interfaceSignature _) _ _, _]) _ _)) -> renameVarTys interfaceSignature freshTy <- case lookupInEnv (SymPath [] name) (getTypeEnv typeEnv) of
Just (_, Binder _ x) -> error ("A non-interface named '" ++ name ++ "' was found in the type environment: " ++ pretty x) Just (_, Binder _ (XObj (Lst [XObj (Interface interfaceSignature _) _ _, _]) _ _)) -> renameVarTys interfaceSignature
Nothing -> genVarTy Just (_, Binder _ x) -> error ("A non-interface named '" ++ name ++ "' was found in the type environment: " ++ pretty x)
pure (Right xobj { xobjTy = Just freshTy }) Nothing -> genVarTy
pure (Right xobj {xobjTy = Just freshTy})
visitArray :: Env -> XObj -> State Integer (Either TypeError XObj) visitArray :: Env -> XObj -> State Integer (Either TypeError XObj)
visitArray env (XObj (Arr xobjs) i _) = visitArray env (XObj (Arr xobjs) i _) =
do visited <- mapM (visit env) xobjs do
arrayVarTy <- genVarTy visited <- mapM (visit env) xobjs
pure $ do okVisited <- sequence visited arrayVarTy <- genVarTy
Right (XObj (Arr okVisited) i (Just (StructTy (ConcreteNameTy "Array") [arrayVarTy]))) 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." visitArray _ _ = error "The function 'visitArray' only accepts XObj:s with arrays in them."
visitStaticArray :: Env -> XObj -> State Integer (Either TypeError XObj) visitStaticArray :: Env -> XObj -> State Integer (Either TypeError XObj)
visitStaticArray env (XObj (StaticArr xobjs) i _) = visitStaticArray env (XObj (StaticArr xobjs) i _) =
do visited <- mapM (visit env) xobjs do
arrayVarTy <- genVarTy visited <- mapM (visit env) xobjs
lt <- genVarTy arrayVarTy <- genVarTy
pure $ do okVisited <- sequence visited lt <- genVarTy
Right (XObj (StaticArr okVisited) i (Just (RefTy (StructTy (ConcreteNameTy "StaticArray") [arrayVarTy]) lt))) 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." visitStaticArray _ _ = error "The function 'visitStaticArray' only accepts XObj:s with arrays in them."
visitDictionary :: Env -> XObj -> State Integer (Either TypeError XObj) visitDictionary :: Env -> XObj -> State Integer (Either TypeError XObj)
visitDictionary env (XObj (Dict xobjs) i _) = visitDictionary env (XObj (Dict xobjs) i _) =
do visited <- mapM (visit env) xobjs do
arrayVarTy <- genVarTy visited <- mapM (visit env) xobjs
pure $ do okVisited <- sequence visited arrayVarTy <- genVarTy
Right (XObj (Dict okVisited) i (Just (StructTy (ConcreteNameTy "Dictionary") [arrayVarTy]))) 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." visitDictionary _ _ = error "The function 'visitArray' only accepts XObj:s with dictionaries in them."
getTys env argList = getTys env argList =
do argTypes <- genVarTys (length argList) do
returnType <- genVarTy argTypes <- genVarTys (length argList)
funcScopeEnv <- extendEnvWithParamList env argList returnType <- genVarTy
pure (argTypes, returnType, funcScopeEnv) funcScopeEnv <- extendEnvWithParamList env argList
pure (argTypes, returnType, funcScopeEnv)
visitList :: Env -> XObj -> State Integer (Either TypeError XObj) visitList :: Env -> XObj -> State Integer (Either TypeError XObj)
visitList env xobj@(XObj (Lst xobjs) i _) = visitList env xobj@(XObj (Lst xobjs) i _) =
case xobjs of case xobjs of
-- Defn -- Defn
[defn@(XObj (Defn _) _ _), nameSymbol@(XObj (Sym (SymPath _ name) _) _ _), XObj (Arr argList) argsi argst, body] -> [defn@(XObj (Defn _) _ _), nameSymbol@(XObj (Sym (SymPath _ name) _) _ _), XObj (Arr argList) argsi argst, body] ->
do (argTypes, returnType, funcScopeEnv) <- getTys env argList do
let funcTy = Just (FuncTy argTypes returnType StaticLifetimeTy) (argTypes, returnType, funcScopeEnv) <- getTys env argList
typedNameSymbol = nameSymbol { xobjTy = funcTy } let funcTy = Just (FuncTy argTypes returnType StaticLifetimeTy)
-- TODO! After the introduction of 'LookupRecursive' this env shouldn't be needed anymore? (but it is for some reason...) typedNameSymbol = nameSymbol {xobjTy = funcTy}
envWithSelf = extendEnv funcScopeEnv name typedNameSymbol -- TODO! After the introduction of 'LookupRecursive' this env shouldn't be needed anymore? (but it is for some reason...)
visitedBody <- visit envWithSelf body envWithSelf = extendEnv funcScopeEnv name typedNameSymbol
visitedArgs <- mapM (visit envWithSelf) argList visitedBody <- visit envWithSelf body
pure $ do okBody <- visitedBody visitedArgs <- mapM (visit envWithSelf) argList
okArgs <- sequence visitedArgs pure $ do
pure (XObj (Lst [defn, nameSymbol, XObj (Arr okArgs) argsi argst, okBody]) i funcTy) 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 _) _ _), 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
[fn@(XObj (Fn _ _) _ _), XObj (Arr argList) argsi argst, body] -> [fn@(XObj (Fn _ _) _ _), XObj (Arr argList) argsi argst, body] ->
do (argTypes, returnType, funcScopeEnv) <- getTys env argList do
lt <- genVarTy (argTypes, returnType, funcScopeEnv) <- getTys env argList
let funcTy = Just (FuncTy argTypes returnType lt) lt <- genVarTy
visitedBody <- visit funcScopeEnv body let funcTy = Just (FuncTy argTypes returnType lt)
visitedArgs <- mapM (visit funcScopeEnv) argList visitedBody <- visit funcScopeEnv body
pure $ do okBody <- visitedBody visitedArgs <- mapM (visit funcScopeEnv) argList
okArgs <- sequence visitedArgs pure $ do
let final = XObj (Lst [fn, XObj (Arr okArgs) argsi argst, okBody]) i funcTy okBody <- visitedBody
pure final --(trace ("FINAL: " ++ show final) final) okArgs <- sequence visitedArgs
let final = XObj (Lst [fn, XObj (Arr okArgs) argsi argst, okBody]) i funcTy
[XObj (Fn _ _ ) _ _, XObj (Arr _) _ _] -> pure (Left (NoFormsInBody xobj)) -- TODO: Special error message for lambdas needed? pure final --(trace ("FINAL: " ++ show final) final)
XObj fn@(Fn _ _) _ _ : _ -> pure (Left (InvalidObj fn xobj)) [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
[def@(XObj Def _ _), nameSymbol, expression]-> [def@(XObj Def _ _), nameSymbol, expression] ->
do definitionType <- genVarTy do
visitedExpr <- visit env expression definitionType <- genVarTy
pure $ do okExpr <- visitedExpr visitedExpr <- visit env expression
pure (XObj (Lst [def, nameSymbol, okExpr]) i (Just definitionType)) pure $ do
okExpr <- visitedExpr
pure (XObj (Lst [def, nameSymbol, okExpr]) i (Just definitionType))
XObj Def _ _ : _ -> pure (Left (InvalidObj Def xobj)) XObj Def _ _ : _ -> pure (Left (InvalidObj Def xobj))
-- DefDynamic -- DefDynamic
[def@(XObj DefDynamic _ _), nameSymbol, expression] -> [def@(XObj DefDynamic _ _), nameSymbol, expression] ->
pure $ pure (XObj (Lst [def, nameSymbol, expression]) i (Just DynamicTy)) pure $ pure (XObj (Lst [def, nameSymbol, expression]) i (Just DynamicTy))
XObj DefDynamic _ _ : _ -> pure (Left (InvalidObj Def xobj)) XObj DefDynamic _ _ : _ -> pure (Left (InvalidObj Def xobj))
-- Let binding -- Let binding
[letExpr@(XObj Let _ _), XObj (Arr bindings) bindi bindt, body] -> [letExpr@(XObj Let _ _), XObj (Arr bindings) bindi bindt, body] ->
do wholeExprType <- genVarTy do
letScopeEnv <- extendEnvWithLetBindings env bindings wholeExprType <- genVarTy
case letScopeEnv of letScopeEnv <- extendEnvWithLetBindings env bindings
Right okLetScopeEnv -> case letScopeEnv of
do visitedBindings <- mapM (visit okLetScopeEnv) bindings Right okLetScopeEnv ->
visitedBody <- visit okLetScopeEnv body do
pure $ do okBindings <- sequence visitedBindings visitedBindings <- mapM (visit okLetScopeEnv) bindings
case getDuplicate [] okBindings of visitedBody <- visit okLetScopeEnv body
Just dup -> Left (DuplicateBinding dup) pure $ do
Nothing -> do okBindings <- sequence visitedBindings
okBody <- visitedBody case getDuplicate [] okBindings of
Right (XObj (Lst [letExpr, XObj (Arr okBindings) bindi bindt, okBody]) i (Just wholeExprType)) Just dup -> Left (DuplicateBinding dup)
Left err -> pure (Left err) Nothing -> do
where getDuplicate _ [] = Nothing okBody <- visitedBody
getDuplicate names (o@(XObj (Sym (SymPath _ x) _) _ _):_:xs) = Right (XObj (Lst [letExpr, XObj (Arr okBindings) bindi bindt, okBody]) i (Just wholeExprType))
if x `elem` names then Just o else getDuplicate (x:names) xs 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 _) _ _] -> [XObj Let _ _, XObj (Arr _) _ _] ->
pure (Left (NoFormsInBody xobj)) pure (Left (NoFormsInBody xobj))
XObj Let _ _ : XObj (Arr _) _ _ : _ -> XObj Let _ _ : XObj (Arr _) _ _ : _ ->
pure (Left (TooManyFormsInBody xobj)) pure (Left (TooManyFormsInBody xobj))
XObj Let _ _ : _ -> XObj Let _ _ : _ ->
pure (Left (InvalidObj Let xobj)) pure (Left (InvalidObj Let xobj))
-- If -- If
[ifExpr@(XObj If _ _), expr, ifTrue, ifFalse] -> [ifExpr@(XObj If _ _), expr, ifTrue, ifFalse] ->
do visitedExpr <- visit env expr do
visitedTrue <- visit env ifTrue visitedExpr <- visit env expr
visitedFalse <- visit env ifFalse visitedTrue <- visit env ifTrue
returnType <- genVarTy visitedFalse <- visit env ifFalse
pure $ do okExpr <- visitedExpr returnType <- genVarTy
okTrue <- visitedTrue pure $ do
okFalse <- visitedFalse okExpr <- visitedExpr
pure (XObj (Lst [ifExpr okTrue <- visitedTrue
,okExpr okFalse <- visitedFalse
,okTrue pure
,okFalse ( XObj
]) i (Just returnType)) ( Lst
[ ifExpr,
okExpr,
okTrue,
okFalse
]
)
i
(Just returnType)
)
XObj If _ _ : _ -> pure (Left (InvalidObj If xobj)) XObj If _ _ : _ -> pure (Left (InvalidObj If xobj))
-- Match -- Match
matchExpr@(XObj (Match _) _ _) : expr : cases -> matchExpr@(XObj (Match _) _ _) : expr : cases ->
do visitedExpr <- visit env expr do
visitedCases <- sequence <$> visitedExpr <- visit env expr
mapM (\(lhs, rhs) -> do let lhs' = uniquifyWildcardNames (helpWithParens lhs) -- Add parens if missing visitedCases <-
env' <- extendEnvWithCaseMatch env lhs' sequence
visitedLhs <- visit env' lhs' <$> mapM
visitedRhs <- visit env' rhs ( \(lhs, rhs) -> do
pure $ do okLhs <- visitedLhs let lhs' = uniquifyWildcardNames (helpWithParens lhs) -- Add parens if missing
okRhs <- visitedRhs env' <- extendEnvWithCaseMatch env lhs'
pure (okLhs, okRhs)) visitedLhs <- visit env' lhs'
(pairwise cases) visitedRhs <- visit env' rhs
returnType <- genVarTy pure $ do
pure $ do okExpr <- visitedExpr okLhs <- visitedLhs
okCases <- visitedCases okRhs <- visitedRhs
let okCasesConcatenated = concatMap (\(a, b) -> [a, b]) okCases pure (okLhs, okRhs)
pure (XObj (Lst ([matchExpr, okExpr] ++ okCasesConcatenated)) )
i (Just returnType)) (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)) XObj (Match m) _ _ : _ -> pure (Left (InvalidObj (Match m) xobj))
-- While (always return Unit) -- While (always return Unit)
[whileExpr@(XObj While _ _), expr, body] -> [whileExpr@(XObj While _ _), expr, body] ->
do visitedExpr <- visit env expr do
visitedBody <- visit env body visitedExpr <- visit env expr
pure $ do okExpr <- visitedExpr visitedBody <- visit env body
okBody <- visitedBody pure $ do
pure (XObj (Lst [whileExpr, okExpr, okBody]) i (Just UnitTy)) okExpr <- visitedExpr
okBody <- visitedBody
pure (XObj (Lst [whileExpr, okExpr, okBody]) i (Just UnitTy))
[XObj While _ _, _] -> [XObj While _ _, _] ->
pure (Left (NoFormsInBody xobj)) pure (Left (NoFormsInBody xobj))
XObj While _ _ : _ -> XObj While _ _ : _ ->
pure (Left (TooManyFormsInBody xobj)) pure (Left (TooManyFormsInBody xobj))
-- Do -- Do
doExpr@(XObj Do _ _) : expressions -> doExpr@(XObj Do _ _) : expressions ->
do t <- genVarTy do
visitedExpressions <- fmap sequence (mapM (visit env) expressions) t <- genVarTy
pure $ do okExpressions <- visitedExpressions visitedExpressions <- fmap sequence (mapM (visit env) expressions)
pure (XObj (Lst (doExpr : okExpressions)) i (Just t)) pure $ do
okExpressions <- visitedExpressions
pure (XObj (Lst (doExpr : okExpressions)) i (Just t))
-- Address -- Address
[addressExpr@(XObj Address _ _), value] -> [addressExpr@(XObj Address _ _), value] ->
do visitedValue <- visit env value do
pure $ do okValue <- visitedValue visitedValue <- visit env value
let Just t' = xobjTy okValue pure $ do
pure (XObj (Lst [addressExpr, okValue]) i (Just (PointerTy t'))) okValue <- visitedValue
let Just t' = xobjTy okValue
pure (XObj (Lst [addressExpr, okValue]) i (Just (PointerTy t')))
-- Set! -- Set!
[setExpr@(XObj SetBang _ _), variable, value] -> [setExpr@(XObj SetBang _ _), variable, value] ->
do visitedVariable <- visit env variable do
visitedValue <- visit env value visitedVariable <- visit env variable
pure $ do okVariable <- visitedVariable visitedValue <- visit env value
okValue <- visitedValue pure $ do
pure (XObj (Lst [setExpr, okVariable, okValue]) i (Just UnitTy)) okVariable <- visitedVariable
okValue <- visitedValue
pure (XObj (Lst [setExpr, okVariable, okValue]) i (Just UnitTy))
XObj SetBang _ _ : _ -> pure (Left (InvalidObj SetBang xobj)) XObj SetBang _ _ : _ -> pure (Left (InvalidObj SetBang xobj))
-- The -- The
[theExpr@(XObj The _ _), typeXObj, value] -> [theExpr@(XObj The _ _), typeXObj, value] ->
do visitedValue <- visit env value do
pure $ do okValue <- visitedValue visitedValue <- visit env value
case xobjToTy typeXObj of pure $ do
Just okType -> pure (XObj (Lst [theExpr, typeXObj, okValue]) i (Just okType)) okValue <- visitedValue
Nothing -> Left (NotAType typeXObj) 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)) XObj The _ _ : _ -> pure (Left (InvalidObj The xobj))
-- Ref -- Ref
[refExpr@(XObj Ref _ _), value] -> [refExpr@(XObj Ref _ _), value] ->
do visitedValue <- visit env value do
lt <- case value of -- This is to not get lifetime errors when using globals. TODO: Is there a better way?! visitedValue <- visit env value
XObj (Sym _ (LookupGlobal _ _)) _ _ -> pure StaticLifetimeTy lt <- case value of -- This is to not get lifetime errors when using globals. TODO: Is there a better way?!
_ | isLiteral value -> pure StaticLifetimeTy XObj (Sym _ (LookupGlobal _ _)) _ _ -> pure StaticLifetimeTy
| otherwise -> genVarTy _
pure $ do okValue <- visitedValue | isLiteral value -> pure StaticLifetimeTy
let Just valueTy = xobjTy okValue | otherwise -> genVarTy
pure (XObj (Lst [refExpr, okValue]) i (Just (RefTy valueTy lt))) pure $ do
okValue <- visitedValue
let Just valueTy = xobjTy okValue
pure (XObj (Lst [refExpr, okValue]) i (Just (RefTy valueTy lt)))
-- Deref (error!) -- Deref (error!)
[XObj Deref _ _, _] -> [XObj Deref _ _, _] ->
pure (Left (CantUseDerefOutsideFunctionApplication xobj)) pure (Left (CantUseDerefOutsideFunctionApplication xobj))
-- Function application with Deref -- Function application with Deref
XObj (Lst [deref@(XObj Deref _ _), func]) xi _ : args -> XObj (Lst [deref@(XObj Deref _ _), func]) xi _ : args ->
-- TODO: Remove code duplication (taken from function application below) -- TODO: Remove code duplication (taken from function application below)
do t <- genVarTy do
derefTy <- genVarTy t <- genVarTy
visitedFunc <- visit env func derefTy <- genVarTy
visitedArgs <- fmap sequence (mapM (visit env) args) visitedFunc <- visit env func
pure $ do okFunc <- visitedFunc visitedArgs <- fmap sequence (mapM (visit env) args)
okArgs <- visitedArgs pure $ do
pure (XObj (Lst (XObj (Lst [deref, okFunc]) xi (Just derefTy) : okArgs)) i (Just t)) okFunc <- visitedFunc
okArgs <- visitedArgs
pure (XObj (Lst (XObj (Lst [deref, okFunc]) xi (Just derefTy) : okArgs)) i (Just t))
-- Function application -- Function application
func : args -> func : args ->
do t <- genVarTy do
visitedFunc <- visit env func t <- genVarTy
visitedArgs <- fmap sequence (mapM (visit env) args) visitedFunc <- visit env func
pure $ do okFunc <- visitedFunc visitedArgs <- fmap sequence (mapM (visit env) args)
okArgs <- visitedArgs pure $ do
pure (XObj (Lst (okFunc : okArgs)) i (Just t)) okFunc <- visitedFunc
okArgs <- visitedArgs
pure (XObj (Lst (okFunc : okArgs)) i (Just t))
-- Empty list -- Empty list
[] -> pure (Right xobj { xobjTy = Just UnitTy }) [] -> pure (Right xobj {xobjTy = Just UnitTy})
visitList _ _ = error "Must match on list!" visitList _ _ = error "Must match on list!"
extendEnvWithLetBindings :: Env -> [XObj] -> State Integer (Either TypeError Env) extendEnvWithLetBindings :: Env -> [XObj] -> State Integer (Either TypeError Env)
extendEnvWithLetBindings env xobjs = extendEnvWithLetBindings env xobjs =
let pairs = pairwise xobjs let pairs = pairwise xobjs
emptyInnerEnv = Env { envBindings = Map.fromList [] emptyInnerEnv =
, envParent = Just env Env
, envModuleName = Nothing { envBindings = Map.fromList [],
, envUseModules = [] envParent = Just env,
, envMode = InternalEnv envModuleName = Nothing,
, envFunctionNestingLevel = envFunctionNestingLevel env envUseModules = [],
} envMode = InternalEnv,
-- Need to fold (rather than map) to make the previous bindings accessible to the later ones, i.e. (let [a 100 b a] ...) envFunctionNestingLevel = envFunctionNestingLevel env
in foldM createBinderForLetPair (Right emptyInnerEnv) pairs }
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 where
createBinderForLetPair :: Either TypeError Env -> (XObj, XObj) -> State Integer (Either TypeError Env) createBinderForLetPair :: Either TypeError Env -> (XObj, XObj) -> State Integer (Either TypeError Env)
createBinderForLetPair envOrErr (sym, expr) = createBinderForLetPair envOrErr (sym, expr) =
@ -393,63 +424,70 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
Right env' -> Right env' ->
case xobjObj sym of case xobjObj sym of
(Sym (SymPath _ name) _) -> (Sym (SymPath _ name) _) ->
do visited <- visit env' expr do
pure (envAddBinding env' name . Binder emptyMeta <$> visited) visited <- visit env' expr
pure (envAddBinding env' name . Binder emptyMeta <$> visited)
_ -> pure (Left (InvalidLetBinding xobjs (sym, expr))) _ -> pure (Left (InvalidLetBinding xobjs (sym, expr)))
extendEnvWithParamList :: Env -> [XObj] -> State Integer Env extendEnvWithParamList :: Env -> [XObj] -> State Integer Env
extendEnvWithParamList env xobjs = extendEnvWithParamList env xobjs =
do binders <- mapM createBinderForParam xobjs do
pure Env { envBindings = Map.fromList binders binders <- mapM createBinderForParam xobjs
, envParent = Just env pure
, envModuleName = Nothing Env
, envUseModules = [] { envBindings = Map.fromList binders,
, envMode = InternalEnv envParent = Just env,
, envFunctionNestingLevel = envFunctionNestingLevel env envModuleName = Nothing,
} envUseModules = [],
envMode = InternalEnv,
envFunctionNestingLevel = envFunctionNestingLevel env
}
where where
createBinderForParam :: XObj -> State Integer (String, Binder) createBinderForParam :: XObj -> State Integer (String, Binder)
createBinderForParam xobj = createBinderForParam xobj =
case xobjObj xobj of case xobjObj xobj of
(Sym (SymPath _ name) _) -> (Sym (SymPath _ name) _) ->
do t <- genVarTy do
let xobjWithTy = xobj { xobjTy = Just t } t <- genVarTy
pure (name, Binder emptyMeta xobjWithTy) let xobjWithTy = xobj {xobjTy = Just t}
pure (name, Binder emptyMeta xobjWithTy)
_ -> error "Can't create binder for non-symbol parameter." _ -> error "Can't create binder for non-symbol parameter."
extendEnvWithCaseMatch :: Env -> XObj -> State Integer Env extendEnvWithCaseMatch :: Env -> XObj -> State Integer Env
extendEnvWithCaseMatch env caseRoot = extendEnvWithCaseMatch env caseRoot =
do binders <- createBindersForCaseVariable caseRoot do
pure Env { envBindings = Map.fromList binders binders <- createBindersForCaseVariable caseRoot
, envParent = Just env pure
, envModuleName = Nothing Env
, envUseModules = [] { envBindings = Map.fromList binders,
, envMode = InternalEnv envParent = Just env,
, envFunctionNestingLevel = envFunctionNestingLevel env envModuleName = Nothing,
} envUseModules = [],
envMode = InternalEnv,
envFunctionNestingLevel = envFunctionNestingLevel env
}
where where
createBindersForCaseVariable :: XObj -> State Integer [(String, Binder)] createBindersForCaseVariable :: XObj -> State Integer [(String, Binder)]
createBindersForCaseVariable xobj@(XObj (Sym (SymPath _ name) _) _ _) = createBinderInternal xobj name createBindersForCaseVariable xobj@(XObj (Sym (SymPath _ name) _) _ _) = createBinderInternal xobj name
createBindersForCaseVariable xobj@(XObj (MultiSym name _) _ _) = createBinderInternal xobj name createBindersForCaseVariable xobj@(XObj (MultiSym name _) _ _) = createBinderInternal xobj name
createBindersForCaseVariable xobj@(XObj (InterfaceSym name) _ _) = createBinderInternal xobj name createBindersForCaseVariable xobj@(XObj (InterfaceSym name) _ _) = createBinderInternal xobj name
createBindersForCaseVariable (XObj (Lst lst) _ _) = do binders <- mapM createBindersForCaseVariable lst createBindersForCaseVariable (XObj (Lst lst) _ _) = do
pure (concat binders) binders <- mapM createBindersForCaseVariable lst
pure (concat binders)
createBindersForCaseVariable (XObj Ref _ _) = pure [] createBindersForCaseVariable (XObj Ref _ _) = pure []
createBindersForCaseVariable x = error ("Can't create binder for non-symbol in 'case' variable match:" ++ show x) -- TODO: Should use proper error mechanism createBindersForCaseVariable x = error ("Can't create binder for non-symbol in 'case' variable match:" ++ show x) -- TODO: Should use proper error mechanism
createBinderInternal :: XObj -> String -> State Integer [(String, Binder)] createBinderInternal :: XObj -> String -> State Integer [(String, Binder)]
createBinderInternal xobj name = createBinderInternal xobj name =
if isVarName name if isVarName name
-- A variable that will bind to something: then-- A variable that will bind to something:
then do freshTy <- genVarTy do
pure [(name, Binder emptyMeta xobj { xobjTy = Just freshTy })] freshTy <- genVarTy
-- Tags for the sumtypes won't bind to anything: pure [(name, Binder emptyMeta xobj {xobjTy = Just freshTy})]
else pure [] else-- Tags for the sumtypes won't bind to anything:
pure []
uniquifyWildcardNames :: XObj -> XObj uniquifyWildcardNames :: XObj -> XObj
uniquifyWildcardNames (XObj (Sym (SymPath [] "_") mode) (Just i) t) = uniquifyWildcardNames (XObj (Sym (SymPath [] "_") mode) (Just i) t) =
let uniqueName = "wildcard_" ++ show (infoIdentifier i) 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) = uniquifyWildcardNames (XObj (Lst xobjs) i t) =
XObj (Lst (map uniquifyWildcardNames xobjs)) i t XObj (Lst (map uniquifyWildcardNames xobjs)) i t
uniquifyWildcardNames (XObj (Arr 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. -- Interface registration involves associating some concrete form, e.g. a defn with an interface.
-- Registered forms may be used wherever the interface is called. -- Registered forms may be used wherever the interface is called.
-- Registrations are stored w/ the interface in the context type environment. -- Registrations are stored w/ the interface in the context type environment.
module Interfaces (registerInInterfaceIfNeeded, module Interfaces
registerInInterface, ( registerInInterfaceIfNeeded,
retroactivelyRegisterInInterface) where registerInInterface,
retroactivelyRegisterInInterface,
import Data.Either (isRight) )
where
import ColorText import ColorText
import Obj import Constraints
import Data.Either (isRight)
import Data.List (foldl')
import Lookup import Lookup
import Obj
import Types import Types
import Util import Util
import Constraints
import Data.List (foldl')
data InterfaceError = KindMismatch SymPath Ty Ty data InterfaceError
| TypeMismatch SymPath Ty Ty = KindMismatch SymPath Ty Ty
| NonInterface SymPath | TypeMismatch SymPath Ty Ty
| NonInterface SymPath
instance Show InterfaceError where instance Show InterfaceError where
show (KindMismatch path definitionSignature interfaceSignature) = show (KindMismatch path definitionSignature interfaceSignature) =
labelStr "INTERFACE ERROR" labelStr
(show path ++ ":" ++ " One or more types in the interface implementation " ++ "INTERFACE ERROR"
show definitionSignature ++ " have kinds that do not match the kinds of the types in the interface signature " ++ ( show path ++ ":" ++ " One or more types in the interface implementation "
show interfaceSignature ++ "\n" ++ "Types of the form (f a) must be matched by constructor types such as (Maybe a)") ++ 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) = show (TypeMismatch path definitionSignature interfaceSignature) =
labelStr "INTERFACE ERROR" labelStr
(show path ++ " : " ++ show definitionSignature ++ "INTERFACE ERROR"
" doesn't match the interface signature " ++ show interfaceSignature) ( show path ++ " : " ++ show definitionSignature
++ " doesn't match the interface signature "
++ show interfaceSignature
)
show (NonInterface path) = show (NonInterface path) =
labelStr "INTERFACE ERROR" labelStr
"INTERFACE ERROR"
(show path ++ "Cant' implement the non-interface `" ++ show path ++ "`") (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. -- 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 :: Context -> SymPath -> SymPath -> Ty -> Either String Context
registerInInterfaceIfNeeded ctx path@(SymPath _ _) interface@(SymPath [] name) definitionSignature = registerInInterfaceIfNeeded ctx path@(SymPath _ _) interface@(SymPath [] name) definitionSignature =
maybe (pure ctx) (typeCheck . snd) (lookupInEnv interface typeEnv) maybe (pure ctx) (typeCheck . snd) (lookupInEnv interface typeEnv)
where typeEnv = getTypeEnv (contextTypeEnv ctx) where
typeCheck binder = case binder of typeEnv = getTypeEnv (contextTypeEnv ctx)
Binder _ (XObj (Lst [inter@(XObj (Interface interfaceSignature paths) ii it), isym]) i t) -> typeCheck binder = case binder of
if checkKinds interfaceSignature definitionSignature Binder _ (XObj (Lst [inter@(XObj (Interface interfaceSignature paths) ii it), isym]) i t) ->
-- N.B. the xobjs aren't important here--we only care about types, if checkKinds interfaceSignature definitionSignature
-- thus we pass inter to all three xobj positions. then-- N.B. the xobjs aren't important here--we only care about types,
then if isRight $ solve [Constraint interfaceSignature definitionSignature inter inter inter OrdInterfaceImpl] -- thus we pass inter to all three xobj positions.
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) } if isRight $ solve [Constraint interfaceSignature definitionSignature inter inter inter OrdInterfaceImpl]
else Left (show $ TypeMismatch path definitionSignature interfaceSignature) then
else Left (show $ KindMismatch path definitionSignature interfaceSignature) let updatedInterface = XObj (Lst [XObj (Interface interfaceSignature (addIfNotPresent path paths)) ii it, isym]) i t
_ -> in Right $ ctx {contextTypeEnv = TypeEnv (extendEnv typeEnv name updatedInterface)}
Left (show $ NonInterface interface) 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 -- | Given an XObj and an interface path, ensure that the form is
-- registered with the interface. -- registered with the interface.
@ -67,10 +82,10 @@ registerInInterface ctx xobj interface =
XObj (Lst [XObj Def _ _, XObj (Sym path _) _ _, _]) _ (Just t) -> XObj (Lst [XObj Def _ _, XObj (Sym path _) _ _, _]) _ (Just t) ->
-- Global variables can also be part of an interface -- Global variables can also be part of an interface
registerInInterfaceIfNeeded ctx path interface t registerInInterfaceIfNeeded ctx path interface t
-- So can externals! -- So can externals!
XObj (Lst [XObj (External _) _ _, XObj (Sym path _) _ _, _]) _ (Just t) -> XObj (Lst [XObj (External _) _ _, XObj (Sym path _) _ _, _]) _ (Just t) ->
registerInInterfaceIfNeeded ctx path interface 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) -> XObj (Lst [XObj (Instantiate _) _ _, XObj (Sym path _) _ _]) _ (Just t) ->
registerInInterfaceIfNeeded ctx path interface t registerInInterfaceIfNeeded ctx path interface t
_ -> pure ctx _ -> pure ctx
@ -81,8 +96,10 @@ retroactivelyRegisterInInterface :: Context -> SymPath -> Context
retroactivelyRegisterInInterface ctx interface@(SymPath _ _) = retroactivelyRegisterInInterface ctx interface@(SymPath _ _) =
-- TODO: Don't use error here? -- TODO: Don't use error here?
either (\e -> error e) id resultCtx either (\e -> error e) id resultCtx
where env = contextGlobalEnv ctx where
impls = recursiveLookupAll interface lookupImplementations env env = contextGlobalEnv ctx
resultCtx = foldl' folder (Right ctx) impls impls = recursiveLookupAll interface lookupImplementations env
folder ctx' binder = either Left register' ctx' resultCtx = foldl' folder (Right ctx) impls
where register' ok = registerInInterface ok (binderXObj binder) interface 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 Data.List (foldl')
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Maybe (mapMaybe) import Data.Maybe (mapMaybe)
import Text.EditDistance (defaultEditCosts, levenshteinDistance)
import Types
import Obj
import qualified Meta import qualified Meta
import Obj
import Text.EditDistance (defaultEditCosts, levenshteinDistance)
import Types
-- | The type of generic lookup functions. -- | The type of generic lookup functions.
type LookupFunc a = a -> Env -> [Binder] type LookupFunc a = a -> Env -> [Binder]
@ -18,8 +17,8 @@ lookupInEnv (SymPath [] name) env =
case Map.lookup name (envBindings env) of case Map.lookup name (envBindings env) of
Just found -> Just (env, found) Just found -> Just (env, found)
Nothing -> case envParent env of Nothing -> case envParent env of
Just parent -> lookupInEnv (SymPath [] name) parent Just parent -> lookupInEnv (SymPath [] name) parent
Nothing -> Nothing Nothing -> Nothing
lookupInEnv path@(SymPath (p : ps) name) env = lookupInEnv path@(SymPath (p : ps) name) env =
case Map.lookup p (envBindings env) of case Map.lookup p (envBindings env) of
Just (Binder _ xobj) -> Just (Binder _ xobj) ->
@ -35,13 +34,14 @@ lookupInEnv path@(SymPath (p : ps) name) env =
findAllGlobalVariables :: Env -> [Binder] findAllGlobalVariables :: Env -> [Binder]
findAllGlobalVariables env = findAllGlobalVariables env =
concatMap finder (envBindings env) concatMap finder (envBindings env)
where finder :: Binder -> [Binder] where
finder def@(Binder _ (XObj (Lst (XObj Def _ _ : _)) _ _)) = finder :: Binder -> [Binder]
[def] finder def@(Binder _ (XObj (Lst (XObj Def _ _ : _)) _ _)) =
finder (Binder _ (XObj (Mod innerEnv) _ _)) = [def]
findAllGlobalVariables innerEnv finder (Binder _ (XObj (Mod innerEnv) _ _)) =
finder _ = findAllGlobalVariables innerEnv
[] finder _ =
[]
-- | Find all the possible (imported) symbols that could be referred to -- | Find all the possible (imported) symbols that could be referred to
multiLookup :: String -> Env -> [(Env, Binder)] multiLookup :: String -> Env -> [(Env, Binder)]
@ -50,47 +50,42 @@ multiLookup = multiLookupInternal False
multiLookupALL :: String -> Env -> [(Env, Binder)] multiLookupALL :: String -> Env -> [(Env, Binder)]
multiLookupALL = multiLookupInternal True multiLookupALL = multiLookupInternal True
-- TODO: Many of the local functions defined in the body of multiLookupInternal have been extracted. -- 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. -- Remove the duplication and define this in terms of the more generic/extracted functions.
{-# ANN multiLookupInternal "HLint: ignore Eta reduce" #-} {-# ANN multiLookupInternal "HLint: ignore Eta reduce" #-}
-- | The advanced version of multiLookup that allows for looking into modules that are NOT imported. -- | 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.) -- | Perhaps this function will become unnecessary when all functions can be found through Interfaces? (even 'delete', etc.)
multiLookupInternal :: Bool -> String -> Env -> [(Env, Binder)] multiLookupInternal :: Bool -> String -> Env -> [(Env, Binder)]
multiLookupInternal allowLookupInAllModules name rootEnv = recursiveLookup rootEnv multiLookupInternal allowLookupInAllModules name rootEnv = recursiveLookup rootEnv
where
where lookupInLocalEnv :: String -> Env -> Maybe (Env, Binder) lookupInLocalEnv :: String -> Env -> Maybe (Env, Binder)
lookupInLocalEnv n localEnv = case Map.lookup n (envBindings localEnv) of -- No recurse! lookupInLocalEnv n localEnv = case Map.lookup n (envBindings localEnv) of -- No recurse!
Just b -> Just (localEnv, b) Just b -> Just (localEnv, b)
Nothing -> Nothing Nothing -> Nothing
importsAll :: Env -> [Env]
importsAll :: Env -> [Env] importsAll env =
importsAll env = let envs = mapMaybe (binderToEnv . snd) (Map.toList (envBindings env))
let envs = mapMaybe (binderToEnv . snd) (Map.toList (envBindings env)) in envs ++ concatMap importsAll envs
in envs ++ concatMap importsAll envs -- Only lookup in imported modules (nonrecursively!)
importsNormal :: Env -> [Env]
-- Only lookup in imported modules (nonrecursively!) importsNormal env =
importsNormal :: Env -> [Env] mapMaybe (\path -> fmap getEnvFromBinder (lookupInEnv path env)) (envUseModules env)
importsNormal env = importsLookup :: Env -> [(Env, Binder)]
mapMaybe (\path -> fmap getEnvFromBinder (lookupInEnv path env)) (envUseModules env) importsLookup env =
let envs = (if allowLookupInAllModules then importsAll else importsNormal) env
importsLookup :: Env -> [(Env, Binder)] in mapMaybe (lookupInLocalEnv name) envs
importsLookup env = recursiveLookup :: Env -> [(Env, Binder)]
let envs = (if allowLookupInAllModules then importsAll else importsNormal) env recursiveLookup env =
in mapMaybe (lookupInLocalEnv name) envs let spine = case Map.lookup name (envBindings env) of
Just found -> [(env, found)]
recursiveLookup :: Env -> [(Env, Binder)] Nothing -> []
recursiveLookup env = leaves = importsLookup env
let spine = case Map.lookup name (envBindings env) of above = case envParent env of
Just found -> [(env, found)] Just parent -> recursiveLookup parent
Nothing -> [] Nothing -> []
leaves = importsLookup env in --(trace $ "multiLookupInternal '" ++ name ++ "' " ++ show (envModuleName env) ++ ", spine: " ++ show (fmap snd spine) ++ ", leaves: " ++ show (fmap snd leaves) ++ ", above: " ++ show (fmap snd above))
above = case envParent env of spine ++ leaves ++ above
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 -> Maybe Env
binderToEnv (Binder _ (XObj (Mod e) _ _)) = Just e binderToEnv (Binder _ (XObj (Mod e) _ _)) = Just e
@ -101,7 +96,7 @@ binderToEnv _ = Nothing
importedEnvs :: Env -> [Env] importedEnvs :: Env -> [Env]
importedEnvs env = importedEnvs env =
let envs = mapMaybe (binderToEnv . snd) (Map.toList (envBindings 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 -- | Given an environment, use a lookup function to recursively find all binders
-- in the environment that satisfy the lookup. -- in the environment that satisfy the lookup.
@ -110,32 +105,34 @@ recursiveLookupAll input lookf env =
let spine = lookf input env let spine = lookf input env
leaves = concatMap (lookf input) (importedEnvs env) leaves = concatMap (lookf input) (importedEnvs env)
above = case envParent env of above = case envParent env of
Just parent -> recursiveLookupAll input lookf parent Just parent -> recursiveLookupAll input lookf parent
Nothing -> [] Nothing -> []
in spine ++ leaves ++ above in spine ++ leaves ++ above
-- | Lookup binders by name. -- | Lookup binders by name.
lookupByName :: String -> Env -> [Binder] lookupByName :: String -> Env -> [Binder]
lookupByName name env = lookupByName name env =
let filtered = Map.filterWithKey (\k _ -> k == name) (envBindings 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. -- | Lookup binders that have specified metadata.
lookupByMeta :: String -> Env -> [Binder] lookupByMeta :: String -> Env -> [Binder]
lookupByMeta key env = lookupByMeta key env =
let filtered = Map.filter hasMeta (envBindings env) let filtered = Map.filter hasMeta (envBindings env)
in map snd $ Map.toList filtered in map snd $ Map.toList filtered
where hasMeta b = Meta.binderMember key b where
hasMeta b = Meta.binderMember key b
-- | Given an interface, lookup all binders that implement the interface. -- | Given an interface, lookup all binders that implement the interface.
lookupImplementations :: SymPath -> Env -> [Binder] lookupImplementations :: SymPath -> Env -> [Binder]
lookupImplementations interface env = lookupImplementations interface env =
let binders = lookupByMeta "implements" env let binders = lookupByMeta "implements" env
in filter isImpl binders in filter isImpl binders
where isImpl (Binder meta _) = where
case Meta.get "implements" meta of isImpl (Binder meta _) =
Just (XObj (Lst interfaces) _ _) -> interface `elem` (map getPath interfaces) case Meta.get "implements" meta of
_ -> False Just (XObj (Lst interfaces) _ _) -> interface `elem` (map getPath interfaces)
_ -> False
getEnvFromBinder :: (a, Binder) -> Env getEnvFromBinder :: (a, Binder) -> Env
getEnvFromBinder (_, Binder _ (XObj (Mod foundEnv) _ _)) = foundEnv getEnvFromBinder (_, Binder _ (XObj (Mod foundEnv) _ _)) = foundEnv
@ -148,7 +145,7 @@ multiLookupQualified :: SymPath -> Env -> [(Env, Binder)]
multiLookupQualified (SymPath [] name) rootEnv = multiLookupQualified (SymPath [] name) rootEnv =
-- This case is just like normal multiLookup, we have a name but no qualifyers: -- This case is just like normal multiLookup, we have a name but no qualifyers:
multiLookup name rootEnv multiLookup name rootEnv
multiLookupQualified path@(SymPath (p:_) _) rootEnv = multiLookupQualified path@(SymPath (p : _) _) rootEnv =
case lookupInEnv (SymPath [] p) rootEnv of case lookupInEnv (SymPath [] p) rootEnv of
Just (_, Binder _ (XObj (Mod _) _ _)) -> Just (_, Binder _ (XObj (Mod _) _ _)) ->
-- Found a module with the correct name, that means we should not look at anything else: -- 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 -> [] Nothing -> []
Just _ -> inexactMatch Just _ -> inexactMatch
Nothing -> inexactMatch Nothing -> inexactMatch
where inexactMatch = where
-- No exact match on the first qualifier, will look in various places for a match: inexactMatch =
let fromParent = case envParent rootEnv of -- No exact match on the first qualifier, will look in various places for a match:
Just parent -> multiLookupQualified path parent let fromParent = case envParent rootEnv of
Nothing -> [] Just parent -> multiLookupQualified path parent
fromUsedModules = let usedModules = envUseModules rootEnv Nothing -> []
envs = mapMaybe (\path' -> fmap getEnvFromBinder (lookupInEnv path' rootEnv)) usedModules fromUsedModules =
in concatMap (multiLookupQualified path) envs let usedModules = envUseModules rootEnv
in fromParent ++ fromUsedModules 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 -- | Add an XObj to a specific environment. TODO: rename to envInsert
extendEnv :: Env -> String -> XObj -> Env 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 -> Binder -> Env
envInsertAt env (SymPath [] name) binder = envInsertAt env (SymPath [] name) binder =
envAddBinding env 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 case Map.lookup p (envBindings env) of
Just (Binder meta (XObj (Mod innerEnv) i t)) -> Just (Binder meta (XObj (Mod innerEnv) i t)) ->
let newInnerEnv = Binder meta (XObj (Mod (envInsertAt innerEnv (SymPath ps name) xobj)) 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) Just _ -> error ("Can't insert into non-module: " ++ p)
Nothing -> error ("Can't insert into non-existing module: " ++ p) Nothing -> error ("Can't insert into non-existing module: " ++ p)
envReplaceEnvAt :: Env -> [String] -> Env -> Env envReplaceEnvAt :: Env -> [String] -> Env -> Env
envReplaceEnvAt _ [] replacement = replacement envReplaceEnvAt _ [] replacement = replacement
envReplaceEnvAt env (p:ps) replacement = envReplaceEnvAt env (p : ps) replacement =
case Map.lookup p (envBindings env) of case Map.lookup p (envBindings env) of
Just (Binder _ (XObj (Mod innerEnv) i t)) -> Just (Binder _ (XObj (Mod innerEnv) i t)) ->
let newInnerEnv = Binder emptyMeta (XObj (Mod (envReplaceEnvAt innerEnv ps replacement)) 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) Just _ -> error ("Can't replace non-module: " ++ p)
Nothing -> error ("Can't replace non-existing module: " ++ p) Nothing -> error ("Can't replace non-existing module: " ++ p)
-- | Add a Binder to a specific environment. -- | Add a Binder to a specific environment.
envAddBinding :: Env -> String -> Binder -> Env 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" #-} {-# ANN addListOfBindings "HLint: ignore Eta reduce" #-}
-- | Add a list of bindings to an environment -- | Add a list of bindings to an environment
addListOfBindings :: Env -> [(String, Binder)] -> Env addListOfBindings :: Env -> [(String, Binder)] -> Env
addListOfBindings env bindingsToAdd = foldl' (\e (n, b) -> envAddBinding e n b) env bindingsToAdd 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. -- | Get an inner environment.
getEnv :: Env -> [String] -> Env getEnv :: Env -> [String] -> Env
getEnv env [] = env getEnv env [] = env
getEnv env (p:ps) = case Map.lookup p (envBindings env) of getEnv env (p : ps) = case Map.lookup p (envBindings env) of
Just (Binder _ (XObj (Mod innerEnv) _ _)) -> getEnv innerEnv ps Just (Binder _ (XObj (Mod innerEnv) _ _)) -> getEnv innerEnv ps
Just _ -> error "Can't get non-env." Just _ -> error "Can't get non-env."
Nothing -> error "Can't get env." Nothing -> error "Can't get env."
contextEnv :: Context -> Env contextEnv :: Context -> Env
contextEnv Context{contextInternalEnv=Just e} = e contextEnv Context {contextInternalEnv = Just e} = e
contextEnv Context{contextGlobalEnv=e, contextPath=p} = getEnv e p 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. -- | Checks if an environment is "external", meaning it's either the global scope or a module scope.
envIsExternal :: Env -> Bool envIsExternal :: Env -> Bool
@ -239,22 +238,22 @@ isExternalType _ _ =
-- | Is this type managed - does it need to be freed? -- | Is this type managed - does it need to be freed?
isManaged :: TypeEnv -> Ty -> Bool isManaged :: TypeEnv -> Ty -> Bool
isManaged typeEnv (StructTy (ConcreteNameTy name) _) = isManaged typeEnv (StructTy (ConcreteNameTy name) _) =
(name == "Array") || (name == "StaticArray") || (name == "Dictionary") || ( (name == "Array") || (name == "StaticArray") || (name == "Dictionary")
case lookupInEnv (SymPath [] name) (getTypeEnv typeEnv) of || ( case lookupInEnv (SymPath [] name) (getTypeEnv typeEnv) of
Just (_, Binder _ (XObj (Lst (XObj (ExternalType _) _ _ : _)) _ _)) -> False Just (_, Binder _ (XObj (Lst (XObj (ExternalType _) _ _ : _)) _ _)) -> False
Just (_, Binder _ (XObj (Lst (XObj (Deftype _) _ _ : _)) _ _)) -> True Just (_, Binder _ (XObj (Lst (XObj (Deftype _) _ _ : _)) _ _)) -> True
Just (_, Binder _ (XObj (Lst (XObj (DefSumtype _) _ _ : _)) _ _)) -> True Just (_, Binder _ (XObj (Lst (XObj (DefSumtype _) _ _ : _)) _ _)) -> True
Just (_, Binder _ (XObj wrong _ _)) -> error ("Invalid XObj in type env: " ++ show wrong) 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! Nothing -> error ("Can't find " ++ name ++ " in type env.") -- TODO: Please don't crash here!
) )
isManaged _ StringTy = True isManaged _ StringTy = True
isManaged _ PatternTy = True isManaged _ PatternTy = True
isManaged _ FuncTy{} = True isManaged _ FuncTy {} = True
isManaged _ _ = False isManaged _ _ = False
-- | Is this type a function type? -- | Is this type a function type?
isFunctionType :: Ty -> Bool isFunctionType :: Ty -> Bool
isFunctionType FuncTy{} = True isFunctionType FuncTy {} = True
isFunctionType _ = False isFunctionType _ = False
-- | Is this type a struct type? -- | Is this type a struct type?
@ -265,7 +264,7 @@ isStructType _ = False
keysInEnvEditDistance :: SymPath -> Env -> Int -> [String] keysInEnvEditDistance :: SymPath -> Env -> Int -> [String]
keysInEnvEditDistance (SymPath [] name) env distance = keysInEnvEditDistance (SymPath [] name) env distance =
let candidates = Map.filterWithKey (\k _ -> levenshteinDistance defaultEditCosts k name < distance) (envBindings env) 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 = keysInEnvEditDistance path@(SymPath (p : ps) name) env distance =
case Map.lookup p (envBindings env) of case Map.lookup p (envBindings env) of
Just (Binder _ xobj) -> Just (Binder _ xobj) ->
@ -288,12 +287,12 @@ envReplaceBinding s@(SymPath [] name) binder env =
Nothing -> env Nothing -> env
envReplaceBinding (SymPath _ _) _ _ = error "TODO: cannot replace qualified bindings" envReplaceBinding (SymPath _ _) _ _ = error "TODO: cannot replace qualified bindings"
bindingNames :: Env -> [String] bindingNames :: Env -> [String]
bindingNames = concatMap select . envBindings bindingNames = concatMap select . envBindings
where select :: Binder -> [String] where
select (Binder _ (XObj (Mod i) _ _)) = bindingNames i select :: Binder -> [String]
select (Binder _ obj) = [getName obj] select (Binder _ (XObj (Mod i) _ _)) = bindingNames i
select (Binder _ obj) = [getName obj]
existingMeta :: Env -> XObj -> MetaData existingMeta :: Env -> XObj -> MetaData
existingMeta globalEnv xobj = existingMeta globalEnv xobj =

40
src/Meta.hs
View File

@ -1,12 +1,14 @@
module Meta (stub, module Meta
get, ( stub,
set, get,
fromBinder, set,
getBinderMetaValue, fromBinder,
updateBinderMeta, getBinderMetaValue,
Meta.member, updateBinderMeta,
binderMember Meta.member,
) where binderMember,
)
where
import Data.Map as Map import Data.Map as Map
import Info import Info
@ -19,11 +21,19 @@ import Types
-- (doc foo "A foo.") <- foo hasn't been declared yet. -- (doc foo "A foo.") <- foo hasn't been declared yet.
-- (def foo 0) -- (def foo 0)
stub :: SymPath -> Binder stub :: SymPath -> Binder
stub path = (Binder emptyMeta stub path =
(XObj (Lst [XObj MetaStub Nothing Nothing ( Binder
, XObj (Sym path Symbol) Nothing Nothing]) emptyMeta
(Just dummyInfo) ( XObj
(Just (VarTy "a")))) ( Lst
[ XObj MetaStub Nothing Nothing,
XObj (Sym path Symbol) Nothing Nothing
]
)
(Just dummyInfo)
(Just (VarTy "a"))
)
)
get :: String -> MetaData -> Maybe XObj get :: String -> MetaData -> Maybe XObj
get key meta = Map.lookup key $ getMeta meta get key meta = Map.lookup key $ getMeta meta
@ -40,7 +50,7 @@ getBinderMetaValue key binder =
updateBinderMeta :: Binder -> String -> XObj -> Binder updateBinderMeta :: Binder -> String -> XObj -> Binder
updateBinderMeta binder key value = updateBinderMeta binder key value =
binder { binderMeta = set key value $ fromBinder binder } binder {binderMeta = set key value $ fromBinder binder}
member :: String -> MetaData -> Bool member :: String -> MetaData -> Bool
member key meta = Map.member key $ getMeta meta 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 module Path where
import qualified System.Directory as D import qualified System.Directory as D
import qualified System.FilePath.Posix as FP import qualified System.FilePath.Posix as FP
import qualified System.FilePath.Windows as FPW import qualified System.FilePath.Windows as FPW
@ -7,8 +8,8 @@ import Util
(</>) :: FilePath -> FilePath -> FilePath (</>) :: FilePath -> FilePath -> FilePath
(</>) = case platform of (</>) = case platform of
Windows -> (FPW.</>) Windows -> (FPW.</>)
_ -> (FP.</>) _ -> (FP.</>)
cachePath :: FilePath -> IO FilePath cachePath :: FilePath -> IO FilePath
cachePath = xdgPath D.XdgCache cachePath = xdgPath D.XdgCache

25
src/Polymorphism.hs
View File

@ -1,8 +1,8 @@
module Polymorphism where module Polymorphism where
import Lookup
import Obj import Obj
import Types import Types
import Lookup
-- | Calculate the full, mangled name of a concretized polymorphic function. -- | Calculate the full, mangled name of a concretized polymorphic function.
-- | For example, The 'id' in "(id 3)" will become 'id__int'. -- | For example, The 'id' in "(id 3)" will become 'id__int'.
@ -11,18 +11,17 @@ import Lookup
-- | and similar for internal use. -- | and similar for internal use.
-- | TODO: Environments are passed in different order here!!! -- | TODO: Environments are passed in different order here!!!
nameOfPolymorphicFunction :: TypeEnv -> Env -> Ty -> String -> Maybe SymPath nameOfPolymorphicFunction :: TypeEnv -> Env -> Ty -> String -> Maybe SymPath
nameOfPolymorphicFunction _ env functionType functionName = nameOfPolymorphicFunction _ env functionType functionName =
let foundBinders = multiLookupALL functionName env let foundBinders = multiLookupALL functionName env
in case filter ((\(Just t') -> areUnifiable functionType t') . xobjTy . binderXObj . snd) foundBinders of in case filter ((\(Just t') -> areUnifiable functionType t') . xobjTy . binderXObj . snd) foundBinders of
[] -> Nothing [] -> Nothing
[(_, Binder _ (XObj (Lst (XObj (External (Just name)) _ _ : _)) _ _))] -> [(_, Binder _ (XObj (Lst (XObj (External (Just name)) _ _ : _)) _ _))] ->
Just (SymPath [] name) Just (SymPath [] name)
[(_, Binder _ single)] -> [(_, Binder _ single)] ->
let Just t' = xobjTy single let Just t' = xobjTy single
(SymPath pathStrings name) = getPath single (SymPath pathStrings name) = getPath single
suffix = polymorphicSuffix t' functionType suffix = polymorphicSuffix t' functionType
concretizedPath = SymPath pathStrings (name ++ suffix) concretizedPath = SymPath pathStrings (name ++ suffix)
in Just concretizedPath in Just concretizedPath
_ -> Nothing _ -> 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 #-} {-# LANGUAGE RecordWildCards #-}
module Project where module Project where
import Info import Info
import Util import Util
data Target = Native | Target String data Target = Native | Target String
instance Show Target where instance Show Target where
show Native = "native" show Native = "native"
show (Target x) = x show (Target x) = x
-- | Project (represents a lot of useful information for working at the REPL and building executables) -- | Project (represents a lot of useful information for working at the REPL and building executables)
data Project = Project { projectTitle :: String data Project
, projectIncludes :: [Includer] = Project
, projectCFlags :: [String] { projectTitle :: String,
, projectLibFlags :: [String] projectIncludes :: [Includer],
, projectPkgConfigFlags :: [String] projectCFlags :: [String],
, projectFiles :: [(FilePath, ReloadMode)] projectLibFlags :: [String],
, projectAlreadyLoaded :: [FilePath] projectPkgConfigFlags :: [String],
, projectEchoC :: Bool projectFiles :: [(FilePath, ReloadMode)],
, projectLibDir :: FilePath projectAlreadyLoaded :: [FilePath],
, projectCarpDir :: FilePath projectEchoC :: Bool,
, projectOutDir :: FilePath projectLibDir :: FilePath,
, projectDocsDir :: FilePath projectCarpDir :: FilePath,
, projectDocsLogo :: FilePath projectOutDir :: FilePath,
, projectDocsPrelude :: String projectDocsDir :: FilePath,
, projectDocsURL :: String projectDocsLogo :: FilePath,
, projectDocsGenerateIndex :: Bool projectDocsPrelude :: String,
, projectDocsStyling :: String projectDocsURL :: String,
, projectPrompt :: String projectDocsGenerateIndex :: Bool,
, projectCarpSearchPaths :: [FilePath] projectDocsStyling :: String,
, projectPrintTypedAST :: Bool projectPrompt :: String,
, projectCompiler :: String projectCarpSearchPaths :: [FilePath],
, projectTarget :: Target projectPrintTypedAST :: Bool,
, projectCore :: Bool projectCompiler :: String,
, projectEchoCompilationCommand :: Bool projectTarget :: Target,
, projectCanExecute :: Bool projectCore :: Bool,
, projectFilePathPrintLength :: FilePathPrintLength projectEchoCompilationCommand :: Bool,
, projectGenerateOnly :: Bool projectCanExecute :: Bool,
, projectBalanceHints :: Bool projectFilePathPrintLength :: FilePathPrintLength,
, projectForceReload :: Bool -- Setting this to true will make the `load-once` command work just like `load`. projectGenerateOnly :: Bool,
, projectCModules :: [FilePath] projectBalanceHints :: Bool,
, projectLoadStack :: [FilePath] projectForceReload :: Bool, -- Setting this to true will make the `load-once` command work just like `load`.
} projectCModules :: [FilePath],
projectLoadStack :: [FilePath]
}
projectFlags :: Project -> String projectFlags :: Project -> String
projectFlags proj = joinWithSpace (projectCFlags proj ++ projectLibFlags proj) projectFlags proj = joinWithSpace (projectCFlags proj ++ projectLibFlags proj)
instance Show Project where instance Show Project where
show (Project {..}) = show (Project {..}) =
unlines [ "Title: " ++ projectTitle unlines
, "Compiler: " ++ projectCompiler [ "Title: " ++ projectTitle,
, "Target: " ++ show projectTarget "Compiler: " ++ projectCompiler,
, "Includes:\n " ++ joinIndented (map show projectIncludes) "Target: " ++ show projectTarget,
, "Cflags:\n " ++ joinIndented projectCFlags "Includes:\n " ++ joinIndented (map show projectIncludes),
, "Library flags:\n " ++ joinIndented projectLibFlags "Cflags:\n " ++ joinIndented projectCFlags,
, "Flags for pkg-config:\n "++ joinIndented projectPkgConfigFlags "Library flags:\n " ++ joinIndented projectLibFlags,
, "Carp source files:\n " ++ joinIndented (map showLoader projectFiles) "Flags for pkg-config:\n " ++ joinIndented projectPkgConfigFlags,
, "Already loaded:\n " ++ joinIndented projectAlreadyLoaded "Carp source files:\n " ++ joinIndented (map showLoader projectFiles),
, "Echo C: " ++ showB projectEchoC "Already loaded:\n " ++ joinIndented projectAlreadyLoaded,
, "Echo compilation command: " ++ showB projectEchoCompilationCommand "Echo C: " ++ showB projectEchoC,
, "Can execute: " ++ showB projectCanExecute "Echo compilation command: " ++ showB projectEchoCompilationCommand,
, "Output directory: " ++ projectOutDir "Can execute: " ++ showB projectCanExecute,
, "Docs directory: " ++ projectDocsDir "Output directory: " ++ projectOutDir,
, "Docs logo: " ++ projectDocsLogo "Docs directory: " ++ projectDocsDir,
, "Docs prelude: " ++ projectDocsPrelude "Docs logo: " ++ projectDocsLogo,
, "Docs Project URL: " ++ projectDocsURL "Docs prelude: " ++ projectDocsPrelude,
, "Docs generate index: " ++ showB projectDocsGenerateIndex "Docs Project URL: " ++ projectDocsURL,
, "Docs CSS URL: " ++ projectDocsStyling "Docs generate index: " ++ showB projectDocsGenerateIndex,
, "Library directory: " ++ projectLibDir "Docs CSS URL: " ++ projectDocsStyling,
, "CARP_DIR: " ++ projectCarpDir "Library directory: " ++ projectLibDir,
, "Prompt: " ++ projectPrompt "CARP_DIR: " ++ projectCarpDir,
, "Using Core: " ++ showB projectCore "Prompt: " ++ projectPrompt,
, "Search paths for 'load' command:\n " ++ joinIndented projectCarpSearchPaths "Using Core: " ++ showB projectCore,
, "Print AST (with 'info' command): " ++ showB projectPrintTypedAST "Search paths for 'load' command:\n " ++ joinIndented projectCarpSearchPaths,
, "File path print length (when using --check): " ++ show projectFilePathPrintLength "Print AST (with 'info' command): " ++ showB projectPrintTypedAST,
, "Generate Only: " ++ showB projectGenerateOnly "File path print length (when using --check): " ++ show projectFilePathPrintLength,
, "Balance Hints: " ++ showB projectBalanceHints "Generate Only: " ++ showB projectGenerateOnly,
, "Force Reload: " ++ showB projectForceReload "Balance Hints: " ++ showB projectBalanceHints,
, "C modules:\n " ++ joinIndented projectCModules "Force Reload: " ++ showB projectForceReload,
, "Load stack:\n "++ joinIndented projectLoadStack "C modules:\n " ++ joinIndented projectCModules,
] "Load stack:\n " ++ joinIndented projectLoadStack
where showB b = if b then "true" else "false" ]
joinIndented = joinWith "\n " 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" -- | Represent the inclusion of a C header file, either like <string.h> or "string.h"
data Includer = SystemInclude String data Includer
| RelativeInclude String = SystemInclude String
deriving Eq | RelativeInclude String
deriving (Eq)
instance Show Includer where instance Show Includer where
show (SystemInclude file) = "<" ++ file ++ ">" show (SystemInclude file) = "<" ++ file ++ ">"
show (RelativeInclude 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` -- | 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 :: (FilePath, ReloadMode) -> String
showLoader (fp, DoesReload) = fp showLoader (fp, DoesReload) = fp

303
src/Qualify.hs
View File

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

6
src/Reify.hs
View File

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

161
src/RenderDocs.hs
View File

@ -2,32 +2,35 @@
module RenderDocs where module RenderDocs where
import AssignTypes (typeVariablesInOrderOfAppearance)
import CMark import CMark
import Control.Monad (when) 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 qualified Text.Blaze.Html5 as H
import Text.Blaze.Html5 ((!)) import Text.Blaze.Html5 ((!))
import qualified Text.Blaze.Html5.Attributes as A 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 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- -- 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 -- This might be a duplicate with the work in a PR by @jacereda
beautifyType :: Ty -> Ty beautifyType :: Ty -> Ty
beautifyType t = beautifyType t =
let tys = List.nub (typeVariablesInOrderOfAppearance t) let tys = List.nub (typeVariablesInOrderOfAppearance t)
mappings = Map.fromList (List.zip (List.map (\(VarTy name) -> name) tys) mappings =
(List.map (VarTy . (:[])) ['a'..])) Map.fromList
in replaceTyVars mappings t ( List.zip
(List.map (\(VarTy name) -> name) tys)
(List.map (VarTy . (: [])) ['a' ..])
)
in replaceTyVars mappings t
saveDocsForEnvs :: Project -> [(SymPath, Binder)] -> IO () saveDocsForEnvs :: Project -> [(SymPath, Binder)] -> IO ()
saveDocsForEnvs ctx pathsAndEnvBinders = saveDocsForEnvs ctx pathsAndEnvBinders =
@ -35,10 +38,15 @@ saveDocsForEnvs ctx pathsAndEnvBinders =
title = projectTitle ctx title = projectTitle ctx
generateIndex = projectDocsGenerateIndex ctx generateIndex = projectDocsGenerateIndex ctx
allEnvNames = fmap (getModuleName . fst . getEnvAndMetaFromBinder . snd) pathsAndEnvBinders allEnvNames = fmap (getModuleName . fst . getEnvAndMetaFromBinder . snd) pathsAndEnvBinders
in do mapM_ (saveDocsForEnvBinder ctx allEnvNames) pathsAndEnvBinders in do
when generateIndex (writeFile (dir </> title ++ "_index.html") mapM_ (saveDocsForEnvBinder ctx allEnvNames) pathsAndEnvBinders
(projectIndexPage ctx allEnvNames)) when
putStrLn ("Generated docs to '" ++ dir ++ "'") 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. -- | This function expects a binder that contains an environment, anything else is a runtime error.
getEnvAndMetaFromBinder :: Binder -> (Env, MetaData) getEnvAndMetaFromBinder :: Binder -> (Env, MetaData)
@ -55,36 +63,42 @@ projectIndexPage ctx moduleNames =
htmlHeader = H.toHtml $ projectTitle ctx htmlHeader = H.toHtml $ projectTitle ctx
htmlDoc = commonmarkToHtml [optSafe] $ Text.pack $ projectDocsPrelude ctx htmlDoc = commonmarkToHtml [optSafe] $ Text.pack $ projectDocsPrelude ctx
html = renderHtml $ H.docTypeHtml $ html = renderHtml $ H.docTypeHtml $
do headOfPage css do
H.body $ headOfPage css
H.div ! A.class_ "content" $ H.body
H.a ! A.href (H.stringValue url) $ $ H.div ! A.class_ "content"
do H.div ! A.class_ "logo" $ $ H.a ! A.href (H.stringValue url)
do H.img ! A.src (H.stringValue logo) ! A.alt "Logo" $ do
moduleIndex moduleNames H.div ! A.class_ "logo" $
H.div $ do
do H.h1 htmlHeader H.img ! A.src (H.stringValue logo) ! A.alt "Logo"
H.preEscapedToHtml htmlDoc moduleIndex moduleNames
in html H.div $
do
H.h1 htmlHeader
H.preEscapedToHtml htmlDoc
in html
headOfPage :: String -> H.Html headOfPage :: String -> H.Html
headOfPage css = headOfPage css =
H.head $ H.head $
do H.meta ! A.charset "UTF-8" do
H.meta ! A.name "viewport" ! A.content "width=device-width, initial-scale=1.0, maximum-scale=1.0, user-scalable=0" H.meta ! A.charset "UTF-8"
H.link ! A.rel "stylesheet" ! A.href (H.stringValue css) 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 -> String
getModuleName env = fromMaybe "Global" (envModuleName env) getModuleName env = fromMaybe "Global" (envModuleName env)
saveDocsForEnvBinder :: Project -> [String] -> (SymPath, Binder) -> IO () saveDocsForEnvBinder :: Project -> [String] -> (SymPath, Binder) -> IO ()
saveDocsForEnvBinder ctx moduleNames (envPath, envBinder) = saveDocsForEnvBinder ctx moduleNames (envPath, envBinder) =
do let SymPath _ moduleName = envPath do
dir = projectDocsDir ctx let SymPath _ moduleName = envPath
fullPath = dir </> moduleName ++ ".html" dir = projectDocsDir ctx
string = renderHtml (envBinderToHtml envBinder ctx (show envPath) moduleNames) fullPath = dir </> moduleName ++ ".html"
createDirectoryIfMissing False dir string = renderHtml (envBinderToHtml envBinder ctx (show envPath) moduleNames)
writeFile fullPath string createDirectoryIfMissing False dir
writeFile fullPath string
envBinderToHtml :: Binder -> Project -> String -> [String] -> H.Html envBinderToHtml :: Binder -> Project -> String -> [String] -> H.Html
envBinderToHtml envBinder ctx moduleName moduleNames = envBinderToHtml envBinder ctx moduleName moduleNames =
@ -94,22 +108,25 @@ envBinderToHtml envBinder ctx moduleName moduleNames =
url = projectDocsURL ctx url = projectDocsURL ctx
logo = projectDocsLogo ctx logo = projectDocsLogo ctx
moduleDescription = case Meta.get "doc" meta of moduleDescription = case Meta.get "doc" meta of
Just (XObj (Str s) _ _) -> s Just (XObj (Str s) _ _) -> s
Nothing -> "" Nothing -> ""
moduleDescriptionHtml = commonmarkToHtml [optSafe] $ Text.pack moduleDescription moduleDescriptionHtml = commonmarkToHtml [optSafe] $ Text.pack moduleDescription
in H.docTypeHtml $ in H.docTypeHtml $
do headOfPage css do
H.body $ headOfPage css
H.div ! A.class_ "content" $ H.body
do H.div ! A.class_ "logo" $ $ H.div ! A.class_ "content"
do H.a ! A.href (H.stringValue url) $ $ do
H.img ! A.src (H.stringValue logo) H.div ! A.class_ "logo" $
--span_ "CARP DOCS FOR" do
H.div ! A.class_ "title" $ H.toHtml title H.a ! A.href (H.stringValue url) $
moduleIndex moduleNames H.img ! A.src (H.stringValue logo)
H.h1 (H.toHtml moduleName) --span_ "CARP DOCS FOR"
H.div ! A.class_ "module-description" $ H.preEscapedToHtml moduleDescriptionHtml H.div ! A.class_ "title" $ H.toHtml title
mapM_ (binderToHtml . snd) (Prelude.filter shouldEmitDocsForBinder (Map.toList (envBindings env))) 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 :: (String, Binder) -> Bool
shouldEmitDocsForBinder (_, Binder meta _) = shouldEmitDocsForBinder (_, Binder meta _) =
@ -117,34 +134,36 @@ shouldEmitDocsForBinder (_, Binder meta _) =
moduleIndex :: [String] -> H.Html moduleIndex :: [String] -> H.Html
moduleIndex moduleNames = moduleIndex moduleNames =
H.div ! A.class_ "index" $ H.div ! A.class_ "index"
H.ul $ mapM_ moduleLink moduleNames $ H.ul
$ mapM_ moduleLink moduleNames
moduleLink :: String -> H.Html moduleLink :: String -> H.Html
moduleLink name = moduleLink name =
H.li $ H.a ! A.href (H.stringValue (name ++ ".html")) $ H.toHtml name H.li $ H.a ! A.href (H.stringValue (name ++ ".html")) $ H.toHtml name
binderToHtml :: Binder -> H.Html binderToHtml :: Binder -> H.Html
binderToHtml (Binder meta xobj) = binderToHtml (Binder meta xobj) =
let name = getSimpleName xobj let name = getSimpleName xobj
maybeNameAndArgs = getSimpleNameWithArgs xobj maybeNameAndArgs = getSimpleNameWithArgs xobj
description = getBinderDescription xobj description = getBinderDescription xobj
typeSignature = case xobjTy xobj of typeSignature = case xobjTy xobj of
Just t -> show (beautifyType t) -- NOTE: This destroys user-defined names of type variables! Just t -> show (beautifyType t) -- NOTE: This destroys user-defined names of type variables!
Nothing -> "" Nothing -> ""
docString = case Meta.get "doc" meta of docString = case Meta.get "doc" meta of
Just (XObj (Str s) _ _) -> s Just (XObj (Str s) _ _) -> s
Just found -> pretty found Just found -> pretty found
Nothing -> "" Nothing -> ""
htmlDoc = commonmarkToHtml [optSafe] $ Text.pack docString htmlDoc = commonmarkToHtml [optSafe] $ Text.pack docString
in H.div ! A.class_ "binder" $ in H.div ! A.class_ "binder" $
do H.a ! A.class_ "anchor" ! A.href (H.stringValue ("#" ++ name)) $ do
H.h3 ! A.id (H.stringValue name) $ H.toHtml name H.a ! A.class_ "anchor" ! A.href (H.stringValue ("#" ++ name))
H.div ! A.class_ "description" $ H.toHtml description $ H.h3 ! A.id (H.stringValue name)
H.p ! A.class_ "sig" $ H.toHtml typeSignature $ H.toHtml name
case maybeNameAndArgs of H.div ! A.class_ "description" $ H.toHtml description
Just nameAndArgs -> H.pre ! A.class_ "args" $ H.toHtml nameAndArgs H.p ! A.class_ "sig" $ H.toHtml typeSignature
Nothing -> H.span $ H.toHtml (""::String) case maybeNameAndArgs of
H.p ! A.class_ "doc" $ H.preEscapedToHtml htmlDoc Just nameAndArgs -> H.pre ! A.class_ "args" $ H.toHtml nameAndArgs
--p_ (toHtml (description)) 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 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 ColorText
import Control.Monad.State.Strict
import Data.List (isPrefixOf)
import qualified Data.Map as Map
import Eval import Eval
import Path
import Lookup import Lookup
import Obj
import Parsing (balance) 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 -> String -> [Completion]
completeKeywordsAnd context word = completeKeywordsAnd context word =
findKeywords word (bindingNames (contextGlobalEnv context) ++ keywords) [] findKeywords word (bindingNames (contextGlobalEnv context) ++ keywords) []
where where
findKeywords _ [] res = res findKeywords _ [] res = res
findKeywords match (x : xs) res = findKeywords match (x : xs) res =
if match `isPrefixOf` x if match `isPrefixOf` x
then findKeywords match xs (res ++ [simpleCompletion x]) then findKeywords match xs (res ++ [simpleCompletion x])
else findKeywords match xs res else findKeywords match xs res
keywords = [ "Int" -- we should probably have a list of those somewhere keywords =
, "Float" [ "Int", -- we should probably have a list of those somewhere
, "Double" "Float",
, "Bool" "Double",
, "String" "Bool",
, "Char" "String",
, "Array" "Char",
, "Fn" "Array",
"Fn",
, "def" "def",
, "defn" "defn",
, "let" "let",
, "do" "do",
, "if" "if",
, "while" "while",
, "ref" "ref",
, "address" "address",
, "set!" "set!",
, "the" "the",
"defmacro",
, "defmacro" "dynamic",
, "dynamic" "quote",
, "quote" "car",
, "car" "cdr",
, "cdr" "cons",
, "cons" "list",
, "list" "array",
, "array" "expand",
, "expand" "deftype",
"register",
, "deftype" "true",
"false"
, "register" ]
, "true"
, "false"
]
readlineSettings :: String -> Settings (StateT Context IO) readlineSettings :: String -> Settings (StateT Context IO)
readlineSettings historyPath = readlineSettings historyPath =
Settings { Settings
complete = completeWordWithPrev Nothing ['(', ')', '[', ']', ' ', '\t', '\n'] { complete =
(\_ w -> do completeWordWithPrev
ctx <- get Nothing
pure (completeKeywordsAnd ctx w)), ['(', ')', '[', ']', ' ', '\t', '\n']
historyFile = Just historyPath, ( \_ w -> do
autoAddHistory = True ctx <- get
} pure (completeKeywordsAnd ctx w)
),
historyFile = Just historyPath,
autoAddHistory = True
}
specialCommands :: Map.Map Char String specialCommands :: Map.Map Char String
specialCommands = Map.fromList specialCommands =
[ ('x', "run") Map.fromList
, ('r', "reload") [ ('x', "run"),
, ('b', "build") ('r', "reload"),
, ('c', "cat") ('b', "build"),
, ('e', "env") ('c', "cat"),
, ('h', "help") ('e', "env"),
, ('p', "project") ('h', "help"),
, ('q', "quit") ('p', "project"),
, ('t', "type") ('q', "quit"),
, ('m', "expand") ('t', "type"),
, ('i', "info") ('m', "expand"),
] ('i', "info")
]
rewriteError :: String -> String rewriteError :: String -> String
rewriteError msg = "(macro-error \"" ++ msg ++ "\")" rewriteError msg = "(macro-error \"" ++ msg ++ "\")"
treatSpecialInput :: String -> String treatSpecialInput :: String -> String
treatSpecialInput ":\n" = rewriteError "Unfinished special command" treatSpecialInput ":\n" = rewriteError "Unfinished special command"
treatSpecialInput (':':rest) = treatSpecialInput (':' : rest) =
let cmdAndArgs = words rest let cmdAndArgs = words rest
cmd = head cmdAndArgs cmd = head cmdAndArgs
args = tail cmdAndArgs args = tail cmdAndArgs
in if length cmd == 1 in if length cmd == 1
then makeCommand args (head cmd) then makeCommand args (head cmd)
else else
if null args if null args
then "(do " ++ unwords (map (makeCommand []) cmd) ++ ")" then "(do " ++ unwords (map (makeCommand []) cmd) ++ ")"
else rewriteError "Can’t have grouped special command with arguments" else rewriteError "Can’t have grouped special command with arguments"
where makeCommand args cmd = where
case Map.lookup cmd specialCommands of makeCommand args cmd =
Just command -> "(" ++ command ++ " " ++ unwords args ++ ")" case Map.lookup cmd specialCommands of
Nothing -> rewriteError ("Unknown special command: :" ++ [cmd]) Just command -> "(" ++ command ++ " " ++ unwords args ++ ")"
Nothing -> rewriteError ("Unknown special command: :" ++ [cmd])
treatSpecialInput arg = arg treatSpecialInput arg = arg
repl :: String -> String -> InputT (StateT Context IO) () repl :: String -> String -> InputT (StateT Context IO) ()
repl readSoFar prompt = repl readSoFar prompt =
do context <- lift $ get do
input <- getInputLine (strWithColor Yellow prompt) context <- lift $ get
case input of input <- getInputLine (strWithColor Yellow prompt)
Nothing -> do case input of
_ <- liftIO exitSuccess Nothing -> do
pure () _ <- liftIO exitSuccess
Just i -> do pure ()
let concatenated = readSoFar ++ i ++ "\n" Just i -> do
balanced = balance concatenated let concatenated = readSoFar ++ i ++ "\n"
proj = contextProj context balanced = balance concatenated
case balanced of proj = contextProj context
"" -> do case balanced of
let input' = if concatenated == "\n" then contextLastInput context else concatenated -- Entering an empty string repeats last input "" -> do
context' <- liftIO $ executeString True True (resetAlreadyLoadedFiles context) (treatSpecialInput input') "REPL" let input' = if concatenated == "\n" then contextLastInput context else concatenated -- Entering an empty string repeats last input
lift $ put context' context' <- liftIO $ executeString True True (resetAlreadyLoadedFiles context) (treatSpecialInput input') "REPL"
repl "" (projectPrompt proj) lift $ put context'
_ -> repl concatenated (if projectBalanceHints proj then balanced else "") repl "" (projectPrompt proj)
_ -> repl concatenated (if projectBalanceHints proj then balanced else "")
resetAlreadyLoadedFiles :: Context -> Context resetAlreadyLoadedFiles :: Context -> Context
resetAlreadyLoadedFiles context = resetAlreadyLoadedFiles context =
let proj = contextProj context let proj = contextProj context
proj' = proj { projectAlreadyLoaded = [] } proj' = proj {projectAlreadyLoaded = []}
in context { contextProj = proj' } in context {contextProj = proj'}
runRepl :: Context -> IO ((), Context) runRepl :: Context -> IO ((), Context)
runRepl context = do runRepl context = do

76
src/Scoring.hs
View File

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

655
src/StartingEnv.hs
View File

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

177
src/StaticArrayTemplates.hs
View File

@ -1,112 +1,129 @@
module StaticArrayTemplates where module StaticArrayTemplates where
import Types import qualified ArrayTemplates
import Concretize
import Obj import Obj
import Template import Template
import ToTemplate import ToTemplate
import Concretize import Types
import qualified ArrayTemplates
-- | NOTE: The code for these templates is copied from ArrayTemplates.hs but -- | 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 -- since there are some small differences here and there I'v decided to not
-- try to abstract over them and just duplicate the templates instead. -- try to abstract over them and just duplicate the templates instead.
concreteArray :: Ty concreteArray :: Ty
concreteArray = (ConcreteNameTy "StaticArray") concreteArray = (ConcreteNameTy "StaticArray")
templateUnsafeNth :: (String, Binder) templateUnsafeNth :: (String, Binder)
templateUnsafeNth = templateUnsafeNth =
let t = VarTy "t" let t = VarTy "t"
in defineTemplate in defineTemplate
(SymPath ["StaticArray"] "unsafe-nth") (SymPath ["StaticArray"] "unsafe-nth")
(FuncTy [RefTy (StructTy concreteArray [t]) (VarTy "q"), IntTy] (RefTy t (VarTy "q")) StaticLifetimeTy) (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`." "gets a reference to the `n`th element from a static array `a`."
(toTemplate "$t* $NAME (Array *aRef, int n)") (toTemplate "$t* $NAME (Array *aRef, int n)")
(toTemplate $ unlines ["$DECL {" ( toTemplate $
," Array a = *aRef;" unlines
," assert(n >= 0);" [ "$DECL {",
," assert(n < a.len);" " Array a = *aRef;",
," return &((($t*)a.data)[n]);" " assert(n >= 0);",
,"}"]) " assert(n < a.len);",
(\(FuncTy [RefTy _ _, _] _ _) -> " return &((($t*)a.data)[n]);",
[]) "}"
]
)
( \(FuncTy [RefTy _ _, _] _ _) ->
[]
)
templateLength :: (String, Binder) templateLength :: (String, Binder)
templateLength = defineTypeParameterizedTemplate templateCreator path t docs templateLength = defineTypeParameterizedTemplate templateCreator path t docs
where path = SymPath ["StaticArray"] "length" where
t = FuncTy [RefTy (StructTy concreteArray [VarTy "t"]) (VarTy "q")] IntTy StaticLifetimeTy path = SymPath ["StaticArray"] "length"
docs = "gets the length of the static array." t = FuncTy [RefTy (StructTy concreteArray [VarTy "t"]) (VarTy "q")] IntTy StaticLifetimeTy
templateCreator = TemplateCreator $ docs = "gets the length of the static array."
\typeEnv env -> templateCreator = TemplateCreator $
Template \typeEnv env ->
t Template
(const (toTemplate "int $NAME (Array *a)")) t
(const (toTemplate "$DECL { return (*a).len; }")) (const (toTemplate "int $NAME (Array *a)"))
(\(FuncTy [RefTy arrayType _] _ _) -> (const (toTemplate "$DECL { return (*a).len; }"))
depsForDeleteFunc typeEnv env arrayType) ( \(FuncTy [RefTy arrayType _] _ _) ->
depsForDeleteFunc typeEnv env arrayType
)
templateDeleteArray :: (String, Binder) templateDeleteArray :: (String, Binder)
templateDeleteArray = defineTypeParameterizedTemplate templateCreator path t docs templateDeleteArray = defineTypeParameterizedTemplate templateCreator path t docs
where path = SymPath ["StaticArray"] "delete" where
t = FuncTy [StructTy concreteArray [VarTy "a"]] UnitTy StaticLifetimeTy path = SymPath ["StaticArray"] "delete"
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)." t = FuncTy [StructTy concreteArray [VarTy "a"]] UnitTy StaticLifetimeTy
templateCreator = TemplateCreator $ 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)."
\typeEnv env -> templateCreator = TemplateCreator $
Template \typeEnv env ->
t Template
(const (toTemplate "void $NAME (Array a)")) t
(\(FuncTy [arrayType] UnitTy _) -> (const (toTemplate "void $NAME (Array a)"))
[TokDecl, TokC "{\n"] ++ ( \(FuncTy [arrayType] UnitTy _) ->
deleteTy typeEnv env arrayType ++ [TokDecl, TokC "{\n"]
[TokC "}\n"]) ++ deleteTy typeEnv env arrayType
(\(FuncTy [(StructTy _ [insideType])] UnitTy _) -> ++ [TokC "}\n"]
depsForDeleteFunc typeEnv env insideType) )
( \(FuncTy [(StructTy _ [insideType])] UnitTy _) ->
depsForDeleteFunc typeEnv env insideType
)
deleteTy :: TypeEnv -> Env -> Ty -> [Token] deleteTy :: TypeEnv -> Env -> Ty -> [Token]
deleteTy typeEnv env (StructTy _ [innerType]) = deleteTy typeEnv env (StructTy _ [innerType]) =
[ TokC " for(int i = 0; i < a.len; i++) {\n" [ TokC " for(int i = 0; i < a.len; i++) {\n",
, TokC $ " " ++ ArrayTemplates.insideArrayDeletion typeEnv env innerType "i" TokC $ " " ++ ArrayTemplates.insideArrayDeletion typeEnv env innerType "i",
, TokC " }\n" TokC " }\n"
] ]
deleteTy _ _ _ = [] deleteTy _ _ _ = []
templateAsetBang :: (String, Binder) templateAsetBang :: (String, Binder)
templateAsetBang = defineTypeParameterizedTemplate templateCreator path t docs templateAsetBang = defineTypeParameterizedTemplate templateCreator path t docs
where path = SymPath ["StaticArray"] "aset!" where
t = FuncTy [RefTy (StructTy concreteArray [VarTy "t"]) (VarTy "q"), IntTy, VarTy "t"] UnitTy StaticLifetimeTy path = SymPath ["StaticArray"] "aset!"
docs = "sets a static array element at the index `n` to a new value in place." t = FuncTy [RefTy (StructTy concreteArray [VarTy "t"]) (VarTy "q"), IntTy, VarTy "t"] UnitTy StaticLifetimeTy
templateCreator = TemplateCreator $ docs = "sets a static array element at the index `n` to a new value in place."
\typeEnv env -> templateCreator = TemplateCreator $
Template \typeEnv env ->
t Template
(const (toTemplate "void $NAME (Array *aRef, int n, $t newValue)")) t
(\(FuncTy [_, _, insideTy] _ _) -> (const (toTemplate "void $NAME (Array *aRef, int n, $t newValue)"))
let deleter = ArrayTemplates.insideArrayDeletion typeEnv env insideTy ( \(FuncTy [_, _, insideTy] _ _) ->
in (toTemplate $ unlines ["$DECL {" let deleter = ArrayTemplates.insideArrayDeletion typeEnv env insideTy
," Array a = *aRef;" in ( toTemplate $
," assert(n >= 0);" unlines
," assert(n < a.len);" [ "$DECL {",
, deleter "n" " Array a = *aRef;",
," (($t*)a.data)[n] = newValue;" " assert(n >= 0);",
,"}"])) " assert(n < a.len);",
(\(FuncTy [RefTy arrayType _, _, _] _ _) -> deleter "n",
depsForDeleteFunc typeEnv env arrayType) " (($t*)a.data)[n] = newValue;",
"}"
]
)
)
( \(FuncTy [RefTy arrayType _, _, _] _ _) ->
depsForDeleteFunc typeEnv env arrayType
)
templateStrArray :: (String, Binder) templateStrArray :: (String, Binder)
templateStrArray = defineTypeParameterizedTemplate templateCreator path t docs templateStrArray = defineTypeParameterizedTemplate templateCreator path t docs
where templateCreator = TemplateCreator $ where
\typeEnv env -> templateCreator = TemplateCreator $
Template \typeEnv env ->
t Template
(const (toTemplate "String $NAME (Array* a)")) t
(\(FuncTy [RefTy arrayType _] StringTy _) -> (const (toTemplate "String $NAME (Array* a)"))
[TokDecl, TokC " {\n"] ++ ( \(FuncTy [RefTy arrayType _] StringTy _) ->
ArrayTemplates.strTy typeEnv env arrayType ++ [TokDecl, TokC " {\n"]
[TokC "}\n"]) ++ ArrayTemplates.strTy typeEnv env arrayType
(\(FuncTy [RefTy (StructTy _ [insideType]) _] StringTy _) -> ++ [TokC "}\n"]
depsForPrnFunc typeEnv env insideType) )
path = SymPath ["StaticArray"] "str" ( \(FuncTy [RefTy (StructTy _ [insideType]) _] StringTy _) ->
t = FuncTy [RefTy (StructTy concreteArray [VarTy "a"]) (VarTy "q")] StringTy StaticLifetimeTy depsForPrnFunc typeEnv env insideType
docs = "converts a static array to a string." )
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 module StructUtils where
import Obj
import Types
import Lookup import Lookup
import Obj
import Polymorphism import Polymorphism
import Types
memberInfo :: TypeEnv -> Ty -> (Ty, String, Ty) memberInfo :: TypeEnv -> Ty -> (Ty, String, Ty)
memberInfo typeEnv memberTy = memberInfo typeEnv memberTy =
let refOrNotRefType = if isManaged typeEnv memberTy then RefTy memberTy (VarTy "w") else memberTy -- OBS! The VarTy "w" here is dubious 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. -- | Generate C code for converting a member variable to a string and appending it to a buffer.
memberPrn :: TypeEnv -> Env -> (String, Ty) -> String memberPrn :: TypeEnv -> Env -> (String, Ty) -> String
@ -18,45 +18,55 @@ memberPrn typeEnv env (memberName, memberTy) =
Just strFunctionPath -> Just strFunctionPath ->
case strFuncType of case strFuncType of
(FuncTy [UnitTy] _ _) -> (FuncTy [UnitTy] _ _) ->
unlines [" temp = " ++ pathToC strFunctionPath ++ "();" unlines
, " sprintf(bufferPtr, \"%s \", temp);" [ " temp = " ++ pathToC strFunctionPath ++ "();",
, " bufferPtr += strlen(temp) + 1;" " sprintf(bufferPtr, \"%s \", temp);",
, " if(temp) { CARP_FREE(temp); temp = NULL; }" " 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;" unlines
, " if(temp) { CARP_FREE(temp); temp = NULL; }" [ " temp = " ++ pathToC strFunctionPath ++ "(" ++ maybeTakeAddress ++ "p->" ++ memberName ++ ");",
] " sprintf(bufferPtr, \"%s \", temp);",
" bufferPtr += strlen(temp) + 1;",
" if(temp) { CARP_FREE(temp); temp = NULL; }"
]
Nothing -> Nothing ->
if isExternalType typeEnv memberTy if isExternalType typeEnv memberTy
then unlines [ " temp = malloc(11);" then
, " sprintf(temp, \"<external>\");" unlines
, " sprintf(bufferPtr, \"%s \", temp);" [ " temp = malloc(11);",
, " bufferPtr += strlen(temp) + 1;" " sprintf(temp, \"<external>\");",
, " if(temp) { CARP_FREE(temp); temp = NULL; }" " sprintf(bufferPtr, \"%s \", temp);",
] " bufferPtr += strlen(temp) + 1;",
else " // Failed to find str function for " ++ memberName ++ " : " ++ show memberTy ++ "\n" " 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 -- | Calculate the size for prn:ing a member of a struct
memberPrnSize :: TypeEnv -> Env -> (String, Ty) -> String memberPrnSize :: TypeEnv -> Env -> (String, Ty) -> String
memberPrnSize typeEnv env (memberName, memberTy) = memberPrnSize typeEnv env (memberName, memberTy) =
let (_, maybeTakeAddress, strFuncType) = memberInfo typeEnv memberTy let (_, maybeTakeAddress, strFuncType) = memberInfo typeEnv memberTy
in case nameOfPolymorphicFunction typeEnv env strFuncType "prn" of in case nameOfPolymorphicFunction typeEnv env strFuncType "prn" of
Just strFunctionPath -> Just strFunctionPath ->
case strFuncType of case strFuncType of
(FuncTy [UnitTy] _ _) -> (FuncTy [UnitTy] _ _) ->
unlines [" temp = " ++ pathToC strFunctionPath ++ "(); " unlines
," size += snprintf(NULL, 0, \"%s \", temp);" [ " temp = " ++ pathToC strFunctionPath ++ "(); ",
," if(temp) { CARP_FREE(temp); temp = NULL; }" " 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; }" unlines
] [ " temp = " ++ pathToC strFunctionPath ++ "(" ++ maybeTakeAddress ++ "p->" ++ memberName ++ "); ",
Nothing -> " size += snprintf(NULL, 0, \"%s \", temp);",
if isExternalType typeEnv memberTy " if(temp) { CARP_FREE(temp); temp = NULL; }"
then unlines [" size += 11;" ]
," if(temp) { CARP_FREE(temp); temp = NULL; }" Nothing ->
] if isExternalType typeEnv memberTy
else " // Failed to find str function for " ++ memberName ++ " : " ++ show memberTy ++ "\n" 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 module SumtypeCase where
import Obj import Obj
import Types
import TypeError import TypeError
import Types
import Validate import Validate
data SumtypeCase = SumtypeCase { caseName :: String data SumtypeCase
, caseTys :: [Ty] = SumtypeCase
} deriving (Show, Eq) { caseName :: String,
caseTys :: [Ty]
}
deriving (Show, Eq)
toCases :: TypeEnv -> [Ty] -> [XObj] -> Either TypeError [SumtypeCase] toCases :: TypeEnv -> [Ty] -> [XObj] -> Either TypeError [SumtypeCase]
toCases typeEnv typeVars xobjs = mapM (toCase typeEnv typeVars) xobjs 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 -> [Ty] -> XObj -> Either TypeError SumtypeCase
toCase typeEnv typeVars x@(XObj (Lst [XObj (Sym (SymPath [] name) Symbol) _ _, XObj (Arr tyXObjs) _ _]) _ _) = toCase typeEnv typeVars x@(XObj (Lst [XObj (Sym (SymPath [] name) Symbol) _ _, XObj (Arr tyXObjs) _ _]) _ _) =
let tys = map xobjToTy tyXObjs let tys = map xobjToTy tyXObjs
in case sequence tys of in case sequence tys of
Nothing -> Nothing ->
Left (InvalidSumtypeCase x) Left (InvalidSumtypeCase x)
Just okTys -> Just okTys ->
let validated = map (\t -> canBeUsedAsMemberType typeEnv typeVars t x) okTys let validated = map (\t -> canBeUsedAsMemberType typeEnv typeVars t x) okTys
in case sequence validated of in case sequence validated of
Left e -> Left e ->
Left e Left e
Right _ -> Right _ ->
Right $ SumtypeCase { caseName = name Right $
, caseTys = okTys SumtypeCase
} { caseName = name,
toCase _ _ (XObj (Sym (SymPath [] name) Symbol) _ _) = caseTys = okTys
Right $ SumtypeCase { caseName = name
, caseTys = []
} }
toCase _ _ (XObj (Sym (SymPath [] name) Symbol) _ _) =
Right $
SumtypeCase
{ caseName = name,
caseTys = []
}
toCase _ _ x = toCase _ _ x =
Left (InvalidSumtypeCase x) Left (InvalidSumtypeCase x)

476
src/Sumtypes.hs
View File

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

113
src/SymPath.hs
View File

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

58
src/Template.hs
View File

@ -1,13 +1,12 @@
module Template where module Template where
import qualified Data.Set as Set import qualified Data.Set as Set
import Util
import Types
import Obj
import ToTemplate
import Info import Info
import qualified Meta import qualified Meta
import Obj
import ToTemplate
import Types
import Util
-- | Create a binding pair used for adding a template instantiation to an environment. -- | Create a binding pair used for adding a template instantiation to an environment.
instanceBinder :: SymPath -> Ty -> Template -> String -> (String, Binder) instanceBinder :: SymPath -> Ty -> Template -> String -> (String, Binder)
@ -15,7 +14,7 @@ instanceBinder path@(SymPath _ name) actualType template docs =
let (x, _) = instantiateTemplate path actualType template let (x, _) = instantiateTemplate path actualType template
docObj = XObj (Str docs) (Just dummyInfo) Nothing docObj = XObj (Str docs) (Just dummyInfo) Nothing
meta = Meta.set "doc" docObj emptyMeta 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 -- | Create a binding pair and don't discard the dependencies
instanceBinderWithDeps :: SymPath -> Ty -> Template -> String -> ((String, Binder), [XObj]) 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 let (x, deps) = instantiateTemplate path actualType template
docObj = XObj (Str docs) (Just dummyInfo) Nothing docObj = XObj (Str docs) (Just dummyInfo) Nothing
meta = Meta.set "doc" docObj emptyMeta 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 -- | 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. -- | 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] defLst = [XObj (Deftemplate (TemplateCreator (\_ _ -> template))) Nothing Nothing, XObj (Sym path Symbol) Nothing Nothing]
docObj = XObj (Str docs) (Just dummyInfo) Nothing docObj = XObj (Str docs) (Just dummyInfo) Nothing
meta = Meta.set "doc" docObj emptyMeta 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. -- | The more advanced version of a template, where the code can vary depending on the type.
defineTypeParameterizedTemplate :: TemplateCreator -> SymPath -> Ty -> String -> (String, Binder) 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] defLst = [XObj (Deftemplate templateCreator) Nothing Nothing, XObj (Sym path Symbol) Nothing Nothing]
docObj = XObj (Str docs) (Just dummyInfo) Nothing docObj = XObj (Str docs) (Just dummyInfo) Nothing
meta = Meta.set "doc" docObj emptyMeta 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 -- | Concretizes the types used in @token
-- @cName is the name of the definition, i.e. the "foo" in "void foo() { ... }" -- @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 let FuncTy argTys retTy lt = t
castToFnWithEnv = tyToCast (FuncTy (lambdaEnvTy : argTys) retTy lt) castToFnWithEnv = tyToCast (FuncTy (lambdaEnvTy : argTys) retTy lt)
castToFn = tyToCast t castToFn = tyToCast t
in in functionName ++ ".env ? "
functionName ++ ".env ? " ++ ++ "(("
"((" ++ castToFnWithEnv ++ ")" ++ functionName ++ ".callback)(" ++ functionName ++ ".env" ++ (if null args then "" else ", ") ++ joinWithComma args ++ ")" ++ ++ castToFnWithEnv
" : " ++ ++ ")"
"((" ++ castToFn ++ ")" ++ functionName ++ ".callback)(" ++ joinWithComma args ++ ")" ++ 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. -- | Must cast a lambda:s .callback member to the correct type to be able to call it.
tyToCast :: Ty -> String tyToCast :: Ty -> String
tyToCast t = tyToCast t =
let FuncTy argTys retTy _ = 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 -- ACTUAL TEMPLATES
-- | This function accepts a pointer and will do nothing with it. -- | This function accepts a pointer and will do nothing with it.
templateNoop :: (String, Binder) templateNoop :: (String, Binder)
templateNoop = defineTemplate templateNoop =
(SymPath [] "noop") defineTemplate
(FuncTy [PointerTy (VarTy "a")] UnitTy StaticLifetimeTy) (SymPath [] "noop")
"accepts a pointer and will do nothing with it." (FuncTy [PointerTy (VarTy "a")] UnitTy StaticLifetimeTy)
(toTemplate "void $NAME ($a* a)") "accepts a pointer and will do nothing with it."
(toTemplate "$DECL { }") (toTemplate "void $NAME ($a* a)")
(const []) (toTemplate "$DECL { }")
(const [])

111
src/ToTemplate.hs
View File

@ -1,78 +1,81 @@
module ToTemplate where module ToTemplate where
import qualified Text.Parsec as Parsec
import Text.Parsec ((<|>))
import Obj import Obj
import Parsing import Parsing
import qualified Text.Parsec as Parsec
import Text.Parsec ((<|>))
import Util import Util
-- | High-level helper function for creating templates from strings of C code. -- | High-level helper function for creating templates from strings of C code.
toTemplate :: String -> [Token] toTemplate :: String -> [Token]
toTemplate text = case Parsec.runParser templateSyntax 0 "(template)" text of toTemplate text = case Parsec.runParser templateSyntax 0 "(template)" text of
Right ok -> ok Right ok -> ok
Left err -> error (show err) Left err -> error (show err)
where where
templateSyntax :: Parsec.Parsec String Int [Token] templateSyntax :: Parsec.Parsec String Int [Token]
templateSyntax = Parsec.many parseTok templateSyntax = Parsec.many parseTok
parseTok =
parseTok = Parsec.try parseTokDecl <|> --- $DECL Parsec.try parseTokDecl
Parsec.try parseTokName <|> --- $NAME <|> Parsec.try parseTokName --- $DECL
Parsec.try parseTokTyGrouped <|> --- i.e. $(Fn [Int] t) <|> Parsec.try parseTokTyGrouped --- $NAME
Parsec.try parseTokTyRawGrouped <|> <|> Parsec.try parseTokTyRawGrouped --- i.e. $(Fn [Int] t)
Parsec.try parseTokTy <|> --- i.e. $t <|> Parsec.try parseTokTy
parseTokC --- Anything else... <|> parseTokC --- i.e. $t
--- Anything else...
parseTokDecl :: Parsec.Parsec String Int Token parseTokDecl :: Parsec.Parsec String Int Token
parseTokDecl = do _ <- Parsec.string "$DECL" parseTokDecl = do
pure TokDecl _ <- Parsec.string "$DECL"
pure TokDecl
parseTokName :: Parsec.Parsec String Int Token parseTokName :: Parsec.Parsec String Int Token
parseTokName = do _ <- Parsec.string "$NAME" parseTokName = do
pure TokName _ <- Parsec.string "$NAME"
pure TokName
parseTokC :: Parsec.Parsec String Int Token parseTokC :: Parsec.Parsec String Int Token
parseTokC = do s <- Parsec.many1 validInSymbol parseTokC = do
pure (TokC s) s <- Parsec.many1 validInSymbol
where validInSymbol = Parsec.choice [Parsec.letter, Parsec.digit, Parsec.oneOf validCharactersInTemplate] pure (TokC s)
validCharactersInTemplate = " ><{}()[]|;:.,_-+*#/'^!?€%&=@\"\n\t\\" where
validInSymbol = Parsec.choice [Parsec.letter, Parsec.digit, Parsec.oneOf validCharactersInTemplate]
validCharactersInTemplate = " ><{}()[]|;:.,_-+*#/'^!?€%&=@\"\n\t\\"
parseTokTy :: Parsec.Parsec String Int Token parseTokTy :: Parsec.Parsec String Int Token
parseTokTy = do _ <- Parsec.char '$' parseTokTy = do
s <- Parsec.many1 Parsec.letter _ <- Parsec.char '$'
pure (toTokTy Normal s) s <- Parsec.many1 Parsec.letter
pure (toTokTy Normal s)
parseTokTyGrouped :: Parsec.Parsec String Int Token parseTokTyGrouped :: Parsec.Parsec String Int Token
parseTokTyGrouped = do _ <- Parsec.char '$' parseTokTyGrouped = do
toTokTy Normal <$> parseGrouping _ <- Parsec.char '$'
toTokTy Normal <$> parseGrouping
parseTokTyRawGrouped :: Parsec.Parsec String Int Token parseTokTyRawGrouped :: Parsec.Parsec String Int Token
parseTokTyRawGrouped = do _ <- Parsec.char '§' parseTokTyRawGrouped = do
toTokTy Raw <$> parseGrouping _ <- Parsec.char '§'
toTokTy Raw <$> parseGrouping
parseGrouping :: Parsec.Parsec String Int String parseGrouping :: Parsec.Parsec String Int String
parseGrouping = do _ <- Parsec.char '(' parseGrouping = do
Parsec.putState 1 -- One paren to close. _ <- Parsec.char '('
fmap ('(' :) (Parsec.many parseCharBalanced) Parsec.putState 1 -- One paren to close.
-- Note: The closing paren is read by parseCharBalanced. fmap ('(' :) (Parsec.many parseCharBalanced)
-- Note: The closing paren is read by parseCharBalanced.
parseCharBalanced :: Parsec.Parsec String Int Char parseCharBalanced :: Parsec.Parsec String Int Char
parseCharBalanced = do balanceState <- Parsec.getState parseCharBalanced = do
if balanceState > 0 balanceState <- Parsec.getState
then Parsec.try openParen <|> if balanceState > 0
Parsec.try closeParen <|> then
Parsec.anyChar Parsec.try openParen
else Parsec.char '\0' -- Should always fail which will end the string. <|> Parsec.try closeParen
<|> Parsec.anyChar
else Parsec.char '\0' -- Should always fail which will end the string.
openParen :: Parsec.Parsec String Int Char openParen :: Parsec.Parsec String Int Char
openParen = do _ <- Parsec.char '(' openParen = do
Parsec.modifyState (+1) _ <- Parsec.char '('
pure '(' Parsec.modifyState (+ 1)
pure '('
closeParen :: Parsec.Parsec String Int Char closeParen :: Parsec.Parsec String Int Char
closeParen = do _ <- Parsec.char ')' closeParen = do
Parsec.modifyState (\x -> x - 1) _ <- Parsec.char ')'
pure ')' Parsec.modifyState (\x -> x - 1)
pure ')'
-- | Converts a string containing a type to a template token ('TokTy'). -- | Converts a string containing a type to a template token ('TokTy').
-- | i.e. the string "(Array Int)" becomes (TokTy (StructTy "Array" IntTy)). -- | i.e. the string "(Array Int)" becomes (TokTy (StructTy "Array" IntTy)).
@ -82,6 +85,6 @@ toTokTy mode s =
Left err -> error (show err) Left err -> error (show err)
Right [] -> error ("toTokTy got [] when parsing: '" ++ s ++ "'") Right [] -> error ("toTokTy got [] when parsing: '" ++ s ++ "'")
Right [xobj] -> case xobjToTy xobj of Right [xobj] -> case xobjToTy xobj of
Just ok -> TokTy ok mode Just ok -> TokTy ok mode
Nothing -> error ("toTokTy failed to convert this s-expression to a type: " ++ pretty xobj) 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)) 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 module TypeError where
import Constraints
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Info
import Types import Lookup
import Obj import Obj
import Project import Project
import Constraints import Types
import Util import Util
import Lookup
import Info
data TypeError = SymbolMissingType XObj Env data TypeError
| DefnMissingType XObj = SymbolMissingType XObj Env
| DefMissingType XObj | DefnMissingType XObj
| ExpressionMissingType XObj | DefMissingType XObj
| SymbolNotDefined SymPath XObj Env | ExpressionMissingType XObj
| InvalidObj Obj XObj | SymbolNotDefined SymPath XObj Env
| CantUseDerefOutsideFunctionApplication XObj | InvalidObj Obj XObj
| NotAType XObj | CantUseDerefOutsideFunctionApplication XObj
| WrongArgCount XObj Int Int | NotAType XObj
| NotAFunction XObj | WrongArgCount XObj Int Int
| NoStatementsInDo XObj | NotAFunction XObj
| TooManyFormsInBody XObj | NoStatementsInDo XObj
| NoFormsInBody XObj | TooManyFormsInBody XObj
| LeadingColon XObj | NoFormsInBody XObj
| UnificationFailed Constraint TypeMappings [Constraint] | LeadingColon XObj
| CantDisambiguate XObj String Ty [(Ty, SymPath)] | UnificationFailed Constraint TypeMappings [Constraint]
| CantDisambiguateInterfaceLookup XObj String Ty [(Ty, SymPath)] | CantDisambiguate XObj String Ty [(Ty, SymPath)]
| SeveralExactMatches XObj String Ty [(Ty, SymPath)] | CantDisambiguateInterfaceLookup XObj String Ty [(Ty, SymPath)]
| NoMatchingSignature XObj String Ty [(Ty, SymPath)] | SeveralExactMatches XObj String Ty [(Ty, SymPath)]
| HolesFound [(String, Ty)] | NoMatchingSignature XObj String Ty [(Ty, SymPath)]
| FailedToExpand XObj EvalError | HolesFound [(String, Ty)]
| NotAValidType XObj | FailedToExpand XObj EvalError
| FunctionsCantReturnRefTy XObj Ty | NotAValidType XObj
| LetCantReturnRefTy XObj Ty | FunctionsCantReturnRefTy XObj Ty
| GettingReferenceToUnownedValue XObj | LetCantReturnRefTy XObj Ty
| UsingUnownedValue XObj | GettingReferenceToUnownedValue XObj
| UsingCapturedValue XObj | UsingUnownedValue XObj
| ArraysCannotContainRefs XObj | UsingCapturedValue XObj
| MainCanOnlyReturnUnitOrInt XObj Ty | ArraysCannotContainRefs XObj
| MainCannotHaveArguments XObj Int | MainCanOnlyReturnUnitOrInt XObj Ty
| CannotConcretize XObj | MainCannotHaveArguments XObj Int
| TooManyAnnotateCalls XObj | CannotConcretize XObj
| CannotSet XObj | TooManyAnnotateCalls XObj
| CannotSetVariableFromLambda XObj XObj | CannotSet XObj
| DoesNotMatchSignatureAnnotation XObj Ty -- Not used at the moment (but should?) | CannotSetVariableFromLambda XObj XObj
| CannotMatch XObj | DoesNotMatchSignatureAnnotation XObj Ty -- Not used at the moment (but should?)
| InvalidSumtypeCase XObj | CannotMatch XObj
| InvalidMemberType Ty XObj | InvalidSumtypeCase XObj
| InvalidMemberTypeWhenConcretizing Ty XObj TypeError | InvalidMemberType Ty XObj
| NotAmongRegisteredTypes Ty XObj | InvalidMemberTypeWhenConcretizing Ty XObj TypeError
| UnevenMembers [XObj] | NotAmongRegisteredTypes Ty XObj
| DuplicatedMembers [XObj] | UnevenMembers [XObj]
| InvalidLetBinding [XObj] (XObj, XObj) | DuplicatedMembers [XObj]
| DuplicateBinding XObj | InvalidLetBinding [XObj] (XObj, XObj)
| DefinitionsMustBeAtToplevel XObj | DuplicateBinding XObj
| UsingDeadReference XObj String | DefinitionsMustBeAtToplevel XObj
| UninhabitedConstructor Ty XObj Int Int | UsingDeadReference XObj String
| UninhabitedConstructor Ty XObj Int Int
instance Show TypeError where instance Show TypeError where
show (SymbolMissingType xobj env) = show (SymbolMissingType xobj env) =
"I couldn’t find a type for the symbol '" ++ getName xobj ++ "' at " ++ "I couldn’t find a type for the symbol '" ++ getName xobj ++ "' at "
prettyInfoFromXObj xobj ++ " in the environment:\n" ++ ++ prettyInfoFromXObj xobj
prettyEnvironment env ++ ++ " in the environment:\n"
"\n\nIt might be too general. You could try adding a type hint using `the`." ++ prettyEnvironment env
++ "\n\nIt might be too general. You could try adding a type hint using `the`."
show (DefnMissingType xobj) = show (DefnMissingType xobj) =
"I couldn’t find a type for the function definition '" ++ getName xobj ++ "I couldn’t find a type for the function definition '" ++ getName xobj
"' at " ++ prettyInfoFromXObj xobj ++ ++ "' at "
".\n\nIt might be too general. You could try adding a type hint using `the`." ++ prettyInfoFromXObj xobj
++ ".\n\nIt might be too general. You could try adding a type hint using `the`."
show (DefMissingType xobj) = show (DefMissingType xobj) =
"I couldn’t find a type for the variable definition '" ++ getName xobj ++ "I couldn’t find a type for the variable definition '" ++ getName xobj
"' at " ++ prettyInfoFromXObj xobj ++ ++ "' at "
".\n\nIt might be too general. You could try adding a type hint using `the`." ++ prettyInfoFromXObj xobj
show (ExpressionMissingType xobj)= ++ ".\n\nIt might be too general. You could try adding a type hint using `the`."
"I couldn’t find a type for the expression '" ++ pretty xobj ++ "' at " ++ show (ExpressionMissingType xobj) =
prettyInfoFromXObj xobj ++ "I couldn’t find a type for the expression '" ++ pretty xobj ++ "' at "
".\n\nIt might be too general. You could try adding a type hint using `the`." ++ prettyInfoFromXObj xobj
++ ".\n\nIt might be too general. You could try adding a type hint using `the`."
show (SymbolNotDefined symPath@(SymPath p _) xobj env) = show (SymbolNotDefined symPath@(SymPath p _) xobj env) =
"I couldn’t find the symbol '" ++ show symPath ++ "' at " ++ "I couldn’t find the symbol '" ++ show symPath ++ "' at "
prettyInfoFromXObj xobj ++ ".\n\n" ++ ++ prettyInfoFromXObj xobj
matches (keysInEnvEditDistance symPath env 3) ++ ".\n\n"
where matches [] = "Maybe you forgot to define it?" ++ matches (keysInEnvEditDistance symPath env 3)
matches x = "Maybe you wanted one of the following?\n " ++ joinWith "\n " (map (show . SymPath p) x) 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) = show (InvalidObj (Defn _) xobj) =
"I didn’t understand the function definition at " ++ "I didn’t understand the function definition at "
prettyInfoFromXObj xobj ++ ++ prettyInfoFromXObj xobj
".\n\nIs it valid? Every `defn` needs to follow the form `(defn name [arg] body)`." ++ ".\n\nIs it valid? Every `defn` needs to follow the form `(defn name [arg] body)`."
show (CantUseDerefOutsideFunctionApplication xobj) = show (CantUseDerefOutsideFunctionApplication xobj) =
"I found a `deref` / `~` that isn’t inside a function application at " ++ "I found a `deref` / `~` that isn’t inside a function application at "
prettyInfoFromXObj xobj ++ ++ prettyInfoFromXObj xobj
".\n\nEvery usage of `~` must be inside a function application." ++ ".\n\nEvery usage of `~` must be inside a function application."
show (InvalidObj If xobj) = show (InvalidObj If xobj) =
"I didn’t understand the `if` statement at " ++ prettyInfoFromXObj 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)`." ++ ".\n\nIs it valid? Every `if` needs to follow the form `(if cond iftrue iffalse)`."
show (InvalidObj o xobj) = show (InvalidObj o xobj) =
"I didn’t understand the form `" ++ show o ++ "` at " ++ "I didn’t understand the form `" ++ show o ++ "` at "
prettyInfoFromXObj xobj ++ ".\n\nIs it valid?" ++ prettyInfoFromXObj xobj
++ ".\n\nIs it valid?"
show (WrongArgCount xobj expected actual) = show (WrongArgCount xobj expected actual) =
"You used the wrong number of arguments in '" ++ getName xobj ++ "' at " ++ "You used the wrong number of arguments in '" ++ getName xobj ++ "' at "
prettyInfoFromXObj xobj ++ ". I expected " ++ show expected ++ ++ prettyInfoFromXObj xobj
", but got " ++ show actual ++ "." ++ ". I expected "
++ show expected
++ ", but got "
++ show actual
++ "."
show (NotAFunction xobj) = show (NotAFunction xobj) =
"You are trying to call the non-function `" ++ getName xobj ++ "` at " ++ "You are trying to call the non-function `" ++ getName xobj ++ "` at "
prettyInfoFromXObj xobj ++ "." ++ prettyInfoFromXObj xobj
++ "."
show (NoStatementsInDo xobj) = show (NoStatementsInDo xobj) =
"There are no expressions inside of the `do` statement at " ++ "There are no expressions inside of the `do` statement at "
prettyInfoFromXObj xobj ++ ++ prettyInfoFromXObj xobj
".\n\nAll instances of `do` need to have one or more expressions in it." ++ ".\n\nAll instances of `do` need to have one or more expressions in it."
show (TooManyFormsInBody xobj) = show (TooManyFormsInBody xobj) =
"There are too many expressions in the body of the form at " ++ "There are too many expressions in the body of the form at "
prettyInfoFromXObj xobj ++ ".\n\nTry wrapping them in a `do`." ++ prettyInfoFromXObj xobj
++ ".\n\nTry wrapping them in a `do`."
show (NoFormsInBody xobj) = show (NoFormsInBody xobj) =
"There are no expressions in the body body of the form at " ++ "There are no expressions in the body body of the form at "
prettyInfoFromXObj xobj ++ ++ prettyInfoFromXObj xobj
".\n\nI need exactly one body form. For multiple forms, try using `do`." ++ ".\n\nI need exactly one body form. For multiple forms, try using `do`."
show (UnificationFailed (Constraint a b aObj bObj ctx _) mappings _) = show (UnificationFailed (Constraint a b aObj bObj ctx _) mappings _) =
"I can’t match the types `" ++ show (recursiveLookupTy mappings a) ++ "I can’t match the types `" ++ show (recursiveLookupTy mappings a)
"` and `" ++ show (recursiveLookupTy mappings b) ++ "`" ++ extra ++ ++ "` and `"
".\n\n" ++ ++ show (recursiveLookupTy mappings b)
--show aObj ++ "\nWITH\n" ++ show bObj ++ "\n\n" ++ ++ "`"
" " ++ pretty aObj ++ " : " ++ showTypeFromXObj mappings aObj ++ ++ extra
"\n At " ++ prettyInfoFromXObj aObj ++ "" ++ ++ ".\n\n"
"\n\n" ++ ++
" " ++ pretty bObj ++ " : " ++ showTypeFromXObj mappings bObj ++ --show aObj ++ "\nWITH\n" ++ show bObj ++ "\n\n" ++
"\n At " ++ prettyInfoFromXObj bObj ++ "\n" " "
-- ++ "Constraint: " ++ show constraint ++ "\n\n" ++ pretty aObj
-- "All constraints:\n" ++ show constraints ++ "\n\n" ++ ++ " : "
-- "Mappings: \n" ++ show mappings ++ "\n\n" ++ showTypeFromXObj mappings aObj
where extra = if ctx == aObj || ctx == bObj then "" else " within `" ++ snip (pretty ctx) ++ "`" ++ "\n At "
snip s = if length s > 25 ++ prettyInfoFromXObj aObj
then take 15 s ++ " ... " ++ drop (length s - 5) s ++ ""
else s ++ "\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) = show (CantDisambiguate xobj originalName theType options) =
"I found an ambiguous symbol `" ++ originalName ++ "` of type `" ++ "I found an ambiguous symbol `" ++ originalName ++ "` of type `"
show theType ++ "` at " ++ prettyInfoFromXObj xobj ++ ++ show theType
"\nPossibilities:\n " ++ ++ "` at "
joinWith "\n " (map (\(t, p) -> show p ++ " : " ++ show t) options) ++ prettyInfoFromXObj xobj
++ "\nPossibilities:\n "
++ joinWith "\n " (map (\(t, p) -> show p ++ " : " ++ show t) options)
show (CantDisambiguateInterfaceLookup xobj name theType options) = show (CantDisambiguateInterfaceLookup xobj name theType options) =
"I found an ambiguous interface `" ++ name ++ "` of type `" ++ "I found an ambiguous interface `" ++ name ++ "` of type `"
show theType ++ "` at " ++ prettyInfoFromXObj xobj ++ ++ show theType
"\nPossibilities:\n " ++ ++ "` at "
joinWith "\n " (map (\(t, p) -> show p ++ " : " ++ show t) options) ++ prettyInfoFromXObj xobj
++ "\nPossibilities:\n "
++ joinWith "\n " (map (\(t, p) -> show p ++ " : " ++ show t) options)
show (SeveralExactMatches xobj name theType options) = show (SeveralExactMatches xobj name theType options) =
"There are several exact matches for the interface `" ++ name ++ "There are several exact matches for the interface `" ++ name
"` of type `" ++ show theType ++ "` at " ++ prettyInfoFromXObj xobj ++ ++ "` of type `"
"\nPossibilities:\n " ++ ++ show theType
joinWith "\n " (map (\(t, p) -> show p ++ " : " ++ show t) options) ++ "` at "
++ prettyInfoFromXObj xobj
++ "\nPossibilities:\n "
++ joinWith "\n " (map (\(t, p) -> show p ++ " : " ++ show t) options)
show (NoMatchingSignature xobj originalName theType options) = show (NoMatchingSignature xobj originalName theType options) =
"I can’t find any implementation for the interface `" ++ originalName ++ "I can’t find any implementation for the interface `" ++ originalName
"` of type " ++ show theType ++ " at " ++ prettyInfoFromXObj xobj ++ ++ "` of type "
".\n\nNone of the possibilities have the correct signature:\n " ++ joinWith ++ show theType
"\n " (map (\(t, p) -> show p ++ " : " ++ show t) options) ++ " 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) = show (LeadingColon xobj) =
"I found a symbol '" ++ pretty xobj ++ "' that starts with a colon at " ++ "I found a symbol '" ++ pretty xobj ++ "' that starts with a colon at "
prettyInfoFromXObj xobj ++ ".\n\nThis is disallowed." ++ prettyInfoFromXObj xobj
++ ".\n\nThis is disallowed."
show (HolesFound holes) = show (HolesFound holes) =
"I found the following holes:\n\n " ++ "I found the following holes:\n\n "
joinWith "\n " (map (\(name, t) -> name ++ " : " ++ show t) holes) ++ ++ joinWith "\n " (map (\(name, t) -> name ++ " : " ++ show t) holes)
"\n" ++ "\n"
show (FailedToExpand xobj err@(EvalError _ hist _ _)) = show (FailedToExpand xobj err@(EvalError _ hist _ _)) =
"I failed to expand a macro at " ++ prettyInfoFromXObj xobj ++ "I failed to expand a macro at " ++ prettyInfoFromXObj xobj
".\n\nThe error message I got was: " ++ show err ++ ++ ".\n\nThe error message I got was: "
"\nTraceback:\n" ++ ++ show err
unlines (map (prettyUpTo 60) hist) ++ "\nTraceback:\n"
++ unlines (map (prettyUpTo 60) hist)
show (NotAValidType xobj) = show (NotAValidType xobj) =
pretty xobj ++ "is not a valid type at " ++ prettyInfoFromXObj xobj pretty xobj ++ "is not a valid type at " ++ prettyInfoFromXObj xobj
show (FunctionsCantReturnRefTy xobj t) = show (FunctionsCantReturnRefTy xobj t) =
"Functions can’t return references. " ++ getName xobj ++ " : " ++ show t "Functions can’t return references. " ++ getName xobj ++ " : " ++ show t
++ " at " ++ prettyInfoFromXObj xobj ++ ++ " at "
"\n\nYou’ll have to copy the return value using `@`." ++ prettyInfoFromXObj xobj
++ "\n\nYou’ll have to copy the return value using `@`."
show (LetCantReturnRefTy xobj t) = show (LetCantReturnRefTy xobj t) =
"`let` expressions can’t return references. " ++ pretty xobj ++ " : " ++ "`let` expressions can’t return references. " ++ pretty xobj ++ " : "
show t ++ " at " ++ prettyInfoFromXObj xobj ++ ++ show t
"\n\nYou’ll have to copy the return value using `@`." ++ " at "
++ prettyInfoFromXObj xobj
++ "\n\nYou’ll have to copy the return value using `@`."
show (GettingReferenceToUnownedValue xobj) = show (GettingReferenceToUnownedValue xobj) =
"You’re referencing a given-away value `" ++ pretty xobj ++ "` at " ++ --"' (expression " ++ freshVar i ++ ") at " ++ "You’re referencing a given-away value `" ++ pretty xobj ++ "` at "
prettyInfoFromXObj xobj ++ "\n" ++ show xobj ++ ++ prettyInfoFromXObj xobj --"' (expression " ++ freshVar i ++ ") at " ++
"\n\nYou’ll have to copy the value using `@`." ++ "\n"
++ show xobj
++ "\n\nYou’ll have to copy the value using `@`."
show (UsingUnownedValue xobj) = show (UsingUnownedValue xobj) =
"You’re using a given-away value `" ++ pretty xobj ++ "` at " ++ "You’re using a given-away value `" ++ pretty xobj ++ "` at "
prettyInfoFromXObj xobj ++ ".\n\nYou’ll have to copy the value using `@`." ++ prettyInfoFromXObj xobj
++ ".\n\nYou’ll have to copy the value using `@`."
show (UsingCapturedValue xobj) = show (UsingCapturedValue xobj) =
"You’re using a value `" ++ pretty xobj ++ "You’re using a value `" ++ pretty xobj
"` that was captured by a function at " ++ prettyInfoFromXObj xobj ++ "." ++ "` that was captured by a function at "
++ prettyInfoFromXObj xobj
++ "."
show (ArraysCannotContainRefs xobj) = show (ArraysCannotContainRefs xobj) =
"Arrays can’t contain references: `" ++ pretty xobj ++ "` at " ++ "Arrays can’t contain references: `" ++ pretty xobj ++ "` at "
prettyInfoFromXObj xobj ++ ".\n\nYou’ll have to make a copy using `@`." ++ prettyInfoFromXObj xobj
++ ".\n\nYou’ll have to make a copy using `@`."
show (MainCanOnlyReturnUnitOrInt _ t) = show (MainCanOnlyReturnUnitOrInt _ t) =
"The main function can only return an `Int` or a unit type (`()`), but it got `" ++ "The main function can only return an `Int` or a unit type (`()`), but it got `"
show t ++ "`." ++ show t
++ "`."
show (MainCannotHaveArguments _ c) = show (MainCannotHaveArguments _ c) =
"The main function may not receive arguments, but it got " ++ show c ++ "." "The main function may not receive arguments, but it got " ++ show c ++ "."
show (CannotConcretize xobj) = show (CannotConcretize xobj) =
"I’m unable to concretize the expression '" ++ pretty xobj ++ "' at " ++ "I’m unable to concretize the expression '" ++ pretty xobj ++ "' at "
prettyInfoFromXObj xobj ++ ++ prettyInfoFromXObj xobj
".\n\nIt might be too general. You could try adding a type hint using `the`." ++ ".\n\nIt might be too general. You could try adding a type hint using `the`."
show (TooManyAnnotateCalls xobj) = show (TooManyAnnotateCalls xobj) =
"There were too many annotation calls when annotating `" ++ pretty xobj ++ "There were too many annotation calls when annotating `" ++ pretty xobj
"` at " ++ prettyInfoFromXObj xobj ++ ++ "` at "
".\n\n I deduced it was an infinite loop." ++ prettyInfoFromXObj xobj
++ ".\n\n I deduced it was an infinite loop."
show (NotAType xobj) = show (NotAType xobj) =
"I don’t understand the type '" ++ pretty xobj ++ "' at " ++ "I don’t understand the type '" ++ pretty xobj ++ "' at "
prettyInfoFromXObj xobj ++ "\n\nIs it defined?" ++ prettyInfoFromXObj xobj
++ "\n\nIs it defined?"
show (CannotSet xobj) = show (CannotSet xobj) =
"I can’t `set!` the expression `" ++ pretty xobj ++ "` at " ++ "I can’t `set!` the expression `" ++ pretty xobj ++ "` at "
prettyInfoFromXObj xobj ++ ".\n\nOnly variables can be reset using `set!`." ++ prettyInfoFromXObj xobj
++ ".\n\nOnly variables can be reset using `set!`."
show (CannotSetVariableFromLambda variable _) = show (CannotSetVariableFromLambda variable _) =
"I can’t `set!` the variable `" ++ pretty variable ++ "` at " ++ "I can’t `set!` the variable `" ++ pretty variable ++ "` at "
prettyInfoFromXObj variable ++ " because it's defined outside the lambda." ++ prettyInfoFromXObj variable
++ " because it's defined outside the lambda."
show (DoesNotMatchSignatureAnnotation xobj sigTy) = show (DoesNotMatchSignatureAnnotation xobj sigTy) =
"The definition at " ++ prettyInfoFromXObj xobj ++ "The definition at " ++ prettyInfoFromXObj xobj
" does not match its annotation provided to `sig` as `" ++ show sigTy ++ ++ " does not match its annotation provided to `sig` as `"
"`, its actual type is `" ++ show (forceTy xobj) ++ "`." ++ show sigTy
++ "`, its actual type is `"
++ show (forceTy xobj)
++ "`."
show (CannotMatch xobj) = show (CannotMatch xobj) =
"I can’t `match` `" ++ pretty xobj ++ "` at " ++ prettyInfoFromXObj xobj ++ "I can’t `match` `" ++ pretty xobj ++ "` at " ++ prettyInfoFromXObj xobj
".\n\nOnly sumtypes can be matched against." ++ ".\n\nOnly sumtypes can be matched against."
show (InvalidSumtypeCase xobj) = show (InvalidSumtypeCase xobj) =
"I failed to read `" ++ pretty xobj ++ "` as a sumtype case at " ++ "I failed to read `" ++ pretty xobj ++ "` as a sumtype case at "
prettyInfoFromXObj xobj ++ ++ prettyInfoFromXObj xobj
".\n\nSumtype cases look like this: `(Foo [Int typevar])`" ++ ".\n\nSumtype cases look like this: `(Foo [Int typevar])`"
show (InvalidMemberType t xobj) = show (InvalidMemberType t xobj) =
"I can’t use the type `" ++ show t ++ "` as a member type at " ++ "I can’t use the type `" ++ show t ++ "` as a member type at "
prettyInfoFromXObj xobj ++ ++ prettyInfoFromXObj xobj
".\n\nIs it defined and captured in the head of the type definition?" ++ ".\n\nIs it defined and captured in the head of the type definition?"
show (InvalidMemberTypeWhenConcretizing t xobj err) = show (InvalidMemberTypeWhenConcretizing t xobj err) =
"I can’t use the concrete type `" ++ show t ++ "` at " ++ prettyInfoFromXObj xobj ++ ": " ++ show err "I can’t use the concrete type `" ++ show t ++ "` at " ++ prettyInfoFromXObj xobj ++ ": " ++ show err
show (NotAmongRegisteredTypes t xobj) = show (NotAmongRegisteredTypes t xobj) =
"I can’t find a definition for the type `" ++ show t ++ "` at " ++ "I can’t find a definition for the type `" ++ show t ++ "` at "
prettyInfoFromXObj xobj ++ ".\n\nWas it registered?" ++ prettyInfoFromXObj xobj
++ ".\n\nWas it registered?"
show (UnevenMembers xobjs) = show (UnevenMembers xobjs) =
"The number of members and types is uneven: `" ++ "The number of members and types is uneven: `"
joinWithComma (map pretty xobjs) ++ "` at " ++ ++ joinWithComma (map pretty xobjs)
prettyInfoFromXObj (head xobjs) ++ ++ "` at "
".\n\nBecause they are pairs of names and their types, they need to be even.\nDid you forget a name or type?" ++ 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) = show (DuplicatedMembers xobjs) =
"Duplicate members: `" ++ "Duplicate members: `"
joinWithComma (map pretty xobjs) ++ "` at " ++ ++ joinWithComma (map pretty xobjs)
prettyInfoFromXObj (head xobjs) ++ "` at "
++ prettyInfoFromXObj (head xobjs)
show (InvalidLetBinding xobjs (sym, expr)) = show (InvalidLetBinding xobjs (sym, expr)) =
"The binding `[" ++ pretty sym ++ " " ++ pretty expr ++ "]` is invalid at " ++ "The binding `[" ++ pretty sym ++ " " ++ pretty expr ++ "]` is invalid at "
prettyInfoFromXObj (head xobjs) ++ ". \n\n Binding names must be symbols." ++ prettyInfoFromXObj (head xobjs)
++ ". \n\n Binding names must be symbols."
show (DuplicateBinding xobj) = show (DuplicateBinding xobj) =
"I encountered a duplicate binding `" ++ pretty xobj ++ "` inside the `let` at " ++ prettyInfoFromXObj xobj ++ "." "I encountered a duplicate binding `" ++ pretty xobj ++ "` inside the `let` at " ++ prettyInfoFromXObj xobj ++ "."
show (DefinitionsMustBeAtToplevel xobj) = show (DefinitionsMustBeAtToplevel xobj) =
"I encountered a definition that was not at top level: `" ++ pretty xobj ++ "`" "I encountered a definition that was not at top level: `" ++ pretty xobj ++ "`"
show (UsingDeadReference xobj dependsOn) = show (UsingDeadReference xobj dependsOn) =
"The reference '" ++ pretty xobj ++ "' (depending on the variable '" ++ dependsOn ++ "') isn't alive at " ++ prettyInfoFromXObj xobj ++ "." "The reference '" ++ pretty xobj ++ "' (depending on the variable '" ++ dependsOn ++ "') isn't alive at " ++ prettyInfoFromXObj xobj ++ "."
show (UninhabitedConstructor ty xobj got wanted) = show (UninhabitedConstructor ty xobj got wanted) =
@ -255,9 +316,9 @@ machineReadableErrorStrings :: FilePathPrintLength -> TypeError -> [String]
machineReadableErrorStrings fppl err = machineReadableErrorStrings fppl err =
case err of case err of
(UnificationFailed (Constraint a b aObj bObj _ _) mappings _) -> (UnificationFailed (Constraint a b aObj bObj _ _) mappings _) ->
[machineReadableInfoFromXObj fppl aObj ++ " Inferred " ++ showTypeFromXObj mappings aObj ++ ", can't unify with " ++ show (recursiveLookupTy mappings b) ++ "." [ 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 bObj ++ " Inferred " ++ showTypeFromXObj mappings bObj ++ ", can't unify with " ++ show (recursiveLookupTy mappings a) ++ "."
]
(DefnMissingType xobj) -> (DefnMissingType xobj) ->
[machineReadableInfoFromXObj fppl xobj ++ " Function definition '" ++ getName xobj ++ "' missing type."] [machineReadableInfoFromXObj fppl xobj ++ " Function definition '" ++ getName xobj ++ "' missing type."]
(DefMissingType xobj) -> (DefMissingType xobj) ->
@ -286,35 +347,37 @@ machineReadableErrorStrings fppl err =
[machineReadableInfoFromXObj fppl xobj ++ " Too many expressions in body position."] [machineReadableInfoFromXObj fppl xobj ++ " Too many expressions in body position."]
(NoFormsInBody xobj) -> (NoFormsInBody xobj) ->
[machineReadableInfoFromXObj fppl xobj ++ " No expressions in body position."] [machineReadableInfoFromXObj fppl xobj ++ " No expressions in body position."]
(CantDisambiguate xobj originalName theType options) -> (CantDisambiguate xobj originalName theType options) ->
[machineReadableInfoFromXObj fppl xobj ++ " Can't disambiguate symbol '" ++ originalName ++ "' of type " ++ show theType ++ [ machineReadableInfoFromXObj fppl xobj ++ " Can't disambiguate symbol '" ++ originalName ++ "' of type " ++ show theType
"\nPossibilities:\n " ++ joinWith "\n " (map (\(t, p) -> show p ++ " : " ++ show t) options)] ++ "\nPossibilities:\n "
++ joinWith "\n " (map (\(t, p) -> show p ++ " : " ++ show t) options)
]
(CantDisambiguateInterfaceLookup xobj name theType options) -> (CantDisambiguateInterfaceLookup xobj name theType options) ->
[machineReadableInfoFromXObj fppl xobj ++ " Can't disambiguate interface lookup symbol '" ++ name ++ "' of type " ++ show theType ++ [ 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)] ++ "\nPossibilities:\n "
++ joinWith "\n " (map (\(t, p) -> show p ++ " : " ++ show t) options)
]
(SeveralExactMatches xobj name theType 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)] [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) -> (NoMatchingSignature xobj originalName theType options) ->
[machineReadableInfoFromXObj fppl xobj ++ " Can't find matching lookup for symbol '" ++ originalName ++ "' of type " ++ show theType ++ [ 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 ++ "\nNone of the possibilities have the correct signature:\n "
"\n " (map (\(t, p) -> show p ++ " : " ++ show t) options)] ++ joinWith
"\n "
(map (\(t, p) -> show p ++ " : " ++ show t) options)
]
(LeadingColon xobj) -> (LeadingColon xobj) ->
[machineReadableInfoFromXObj fppl xobj ++ " Symbol '" ++ pretty xobj ++ "' starting with a colon (reserved for REPL shortcuts)."] [machineReadableInfoFromXObj fppl xobj ++ " Symbol '" ++ pretty xobj ++ "' starting with a colon (reserved for REPL shortcuts)."]
-- (HolesFound holes) -> -- (HolesFound holes) ->
-- (map (\(name, t) -> machineReadableInfoFromXObj fppl xobj ++ " " ++ name ++ " : " ++ show t) holes) -- (map (\(name, t) -> machineReadableInfoFromXObj fppl xobj ++ " " ++ name ++ " : " ++ show t) holes)
(FailedToExpand xobj (EvalError errorMessage _ _ _)) -> (FailedToExpand xobj (EvalError errorMessage _ _ _)) ->
[machineReadableInfoFromXObj fppl xobj ++ "Failed to expand: " ++ errorMessage] [machineReadableInfoFromXObj fppl xobj ++ "Failed to expand: " ++ errorMessage]
-- TODO: Remove overlapping errors: -- TODO: Remove overlapping errors:
(NotAValidType xobj) -> (NotAValidType xobj) ->
[machineReadableInfoFromXObj fppl xobj ++ " Not a valid type: " ++ pretty xobj ++ "."] [machineReadableInfoFromXObj fppl xobj ++ " Not a valid type: " ++ pretty xobj ++ "."]
(NotAType xobj) -> (NotAType xobj) ->
[machineReadableInfoFromXObj fppl xobj ++ " Can't understand the type '" ++ pretty xobj ++ "'."] [machineReadableInfoFromXObj fppl xobj ++ " Can't understand the type '" ++ pretty xobj ++ "'."]
(FunctionsCantReturnRefTy xobj t) -> (FunctionsCantReturnRefTy xobj t) ->
[machineReadableInfoFromXObj fppl xobj ++ " Functions can't return references. " ++ getName xobj ++ " : " ++ show t ++ "."] [machineReadableInfoFromXObj fppl xobj ++ " Functions can't return references. " ++ getName xobj ++ " : " ++ show t ++ "."]
(LetCantReturnRefTy xobj t) -> (LetCantReturnRefTy xobj t) ->
@ -327,35 +390,27 @@ machineReadableErrorStrings fppl err =
[machineReadableInfoFromXObj fppl xobj ++ " Using a captured value '" ++ pretty xobj ++ "'."] [machineReadableInfoFromXObj fppl xobj ++ " Using a captured value '" ++ pretty xobj ++ "'."]
(ArraysCannotContainRefs xobj) -> (ArraysCannotContainRefs xobj) ->
[machineReadableInfoFromXObj fppl xobj ++ " Arrays can't contain references: '" ++ pretty xobj ++ "'."] [machineReadableInfoFromXObj fppl xobj ++ " Arrays can't contain references: '" ++ pretty xobj ++ "'."]
(MainCanOnlyReturnUnitOrInt xobj t) -> (MainCanOnlyReturnUnitOrInt xobj t) ->
[machineReadableInfoFromXObj fppl xobj ++ " Main function can only return Int or (), got " ++ show t ++ "."] [machineReadableInfoFromXObj fppl xobj ++ " Main function can only return Int or (), got " ++ show t ++ "."]
(MainCannotHaveArguments xobj c) -> (MainCannotHaveArguments xobj c) ->
[machineReadableInfoFromXObj fppl xobj ++ " Main function can not have arguments, got " ++ show c ++ "."] [machineReadableInfoFromXObj fppl xobj ++ " Main function can not have arguments, got " ++ show c ++ "."]
(TooManyAnnotateCalls xobj) -> (TooManyAnnotateCalls xobj) ->
[machineReadableInfoFromXObj fppl xobj ++ " Too many annotate calls (infinite loop) when annotating '" ++ pretty xobj ++ "'."] [machineReadableInfoFromXObj fppl xobj ++ " Too many annotate calls (infinite loop) when annotating '" ++ pretty xobj ++ "'."]
-- (InvalidMemberType msg) ->
-- (InvalidMemberType msg) -> -- -- msg
-- -- msg
(CannotSet xobj) -> (CannotSet xobj) ->
[machineReadableInfoFromXObj fppl xobj ++ " Can't set! '" ++ pretty xobj ++ "'."] [machineReadableInfoFromXObj fppl xobj ++ " Can't set! '" ++ pretty xobj ++ "'."]
(CannotSetVariableFromLambda variable _) -> (CannotSetVariableFromLambda variable _) ->
[machineReadableInfoFromXObj fppl variable ++ " Can't set! '" ++ pretty variable ++ "' from inside of a lambda."] [machineReadableInfoFromXObj fppl variable ++ " Can't set! '" ++ pretty variable ++ "' from inside of a lambda."]
(CannotConcretize xobj) -> (CannotConcretize xobj) ->
[machineReadableInfoFromXObj fppl xobj ++ " Unable to concretize '" ++ pretty xobj ++ "'."] [machineReadableInfoFromXObj fppl xobj ++ " Unable to concretize '" ++ pretty xobj ++ "'."]
(DoesNotMatchSignatureAnnotation xobj sigTy) -> (DoesNotMatchSignatureAnnotation xobj sigTy) ->
[machineReadableInfoFromXObj fppl xobj ++ "Definition does not match 'sig' annotation " ++ show sigTy ++ ", actual type is " ++ show (forceTy xobj)] [machineReadableInfoFromXObj fppl xobj ++ "Definition does not match 'sig' annotation " ++ show sigTy ++ ", actual type is " ++ show (forceTy xobj)]
(CannotMatch xobj) -> (CannotMatch xobj) ->
[machineReadableInfoFromXObj fppl xobj ++ " Can't match '" ++ pretty xobj ++ "'."] [machineReadableInfoFromXObj fppl xobj ++ " Can't match '" ++ pretty xobj ++ "'."]
(InvalidSumtypeCase xobj) -> (InvalidSumtypeCase xobj) ->
[machineReadableInfoFromXObj fppl xobj ++ " Failed to convert '" ++ pretty xobj ++ "' to a sumtype case."] [machineReadableInfoFromXObj fppl xobj ++ " Failed to convert '" ++ pretty xobj ++ "' to a sumtype case."]
(InvalidMemberType t xobj) -> (InvalidMemberType t xobj) ->
[machineReadableInfoFromXObj fppl xobj ++ " Can't use '" ++ show t ++ "' as a type for a member variable."] [machineReadableInfoFromXObj fppl xobj ++ " Can't use '" ++ show t ++ "' as a type for a member variable."]
(NotAmongRegisteredTypes t xobj) -> (NotAmongRegisteredTypes t xobj) ->
@ -372,7 +427,6 @@ machineReadableErrorStrings fppl err =
[machineReadableInfoFromXObj fppl xobj ++ " The reference '" ++ pretty xobj ++ "' isn't alive."] [machineReadableInfoFromXObj fppl xobj ++ " The reference '" ++ pretty xobj ++ "' isn't alive."]
(UninhabitedConstructor ty xobj got wanted) -> (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] [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] [show err]
@ -381,14 +435,16 @@ joinedMachineReadableErrorStrings fppl err = joinWith "\n\n" (machineReadableErr
recursiveLookupTy :: TypeMappings -> Ty -> Ty recursiveLookupTy :: TypeMappings -> Ty -> Ty
recursiveLookupTy mappings t = case t of recursiveLookupTy mappings t = case t of
(VarTy v) -> fromMaybe t (recursiveLookup mappings v) (VarTy v) -> fromMaybe t (recursiveLookup mappings v)
(RefTy r lt) -> RefTy (recursiveLookupTy mappings r) (recursiveLookupTy mappings lt) (RefTy r lt) -> RefTy (recursiveLookupTy mappings r) (recursiveLookupTy mappings lt)
(PointerTy p) -> PointerTy (recursiveLookupTy mappings p) (PointerTy p) -> PointerTy (recursiveLookupTy mappings p)
(StructTy n innerTys) -> StructTy n (map (recursiveLookupTy mappings) innerTys) (StructTy n innerTys) -> StructTy n (map (recursiveLookupTy mappings) innerTys)
(FuncTy argTys retTy ltTy) -> FuncTy (map (recursiveLookupTy mappings) argTys) (FuncTy argTys retTy ltTy) ->
(recursiveLookupTy mappings retTy) FuncTy
(recursiveLookupTy mappings ltTy) (map (recursiveLookupTy mappings) argTys)
_ -> t (recursiveLookupTy mappings retTy)
(recursiveLookupTy mappings ltTy)
_ -> t
showTypeFromXObj :: TypeMappings -> XObj -> String showTypeFromXObj :: TypeMappings -> XObj -> String
showTypeFromXObj mappings xobj = showTypeFromXObj mappings xobj =
@ -404,12 +460,13 @@ makeEvalError :: Context -> Maybe TypeError.TypeError -> String -> Maybe Info ->
makeEvalError ctx err msg info = makeEvalError ctx err msg info =
let fppl = projectFilePathPrintLength (contextProj ctx) let fppl = projectFilePathPrintLength (contextProj ctx)
history = contextHistory ctx history = contextHistory ctx
in case contextExecMode ctx of in case contextExecMode ctx of
Check -> let messageWhenChecking = case err of Check ->
Just okErr -> joinedMachineReadableErrorStrings fppl okErr let messageWhenChecking = case err of
Nothing -> Just okErr -> joinedMachineReadableErrorStrings fppl okErr
case info of Nothing ->
Just okInfo -> machineReadableInfo fppl okInfo ++ " " ++ msg case info of
Nothing -> msg Just okInfo -> machineReadableInfo fppl okInfo ++ " " ++ msg
in (ctx, Left (EvalError messageWhenChecking [] fppl Nothing)) -- Passing no history to avoid appending it at the end in 'show' instance for EvalError Nothing -> msg
_ -> (ctx, Left (EvalError msg history fppl info)) 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 module Types
, Ty(..) ( TypeMappings,
, showMaybeTy Ty (..),
, isTypeGeneric showMaybeTy,
, unifySignatures isTypeGeneric,
, replaceTyVars unifySignatures,
, areUnifiable replaceTyVars,
, typesDeleterFunctionType areUnifiable,
, typesCopyFunctionType typesDeleterFunctionType,
, isFullyGenericType typesCopyFunctionType,
, doesTypeContainTyVarWithName isFullyGenericType,
, replaceConflicted doesTypeContainTyVarWithName,
, lambdaEnvTy replaceConflicted,
, typeEqIgnoreLifetimes lambdaEnvTy,
, checkKinds typeEqIgnoreLifetimes,
-- SymPath imports checkKinds,
, SymPath (..) -- SymPath imports
, mangle SymPath (..),
, pathToC mangle,
, consPath pathToC,
, Kind consPath,
, tyToKind Kind,
, isUnit tyToKind,
) where isUnit,
)
where
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Util
import SymPath import SymPath
import Util
--import Debug.Trace --import Debug.Trace
-- | Carp types. -- | Carp types.
data Ty = IntTy data Ty
| LongTy = IntTy
| ByteTy | LongTy
| BoolTy | ByteTy
| FloatTy | BoolTy
| DoubleTy | FloatTy
| StringTy | DoubleTy
| PatternTy | StringTy
| CharTy | PatternTy
| FuncTy [Ty] Ty Ty -- In order of appearance: (1) Argument types, (2) Return type, (3) Lifetime | CharTy
| VarTy String | FuncTy [Ty] Ty Ty -- In order of appearance: (1) Argument types, (2) Return type, (3) Lifetime
| UnitTy | VarTy String
| ModuleTy | UnitTy
| PointerTy Ty | ModuleTy
| RefTy Ty Ty -- second Ty is the lifetime | PointerTy Ty
| StaticLifetimeTy | RefTy Ty Ty -- second Ty is the lifetime
| StructTy Ty [Ty] -- the name (possibly a var) of the struct, and it's type parameters | StaticLifetimeTy
| ConcreteNameTy String -- the name of a struct | StructTy Ty [Ty] -- the name (possibly a var) of the struct, and it's type parameters
| TypeTy -- the type of types | ConcreteNameTy String -- the name of a struct
| MacroTy | TypeTy -- the type of types
| DynamicTy -- the type of dynamic functions (used in REPL and macros) | MacroTy
| InterfaceTy | DynamicTy -- the type of dynamic functions (used in REPL and macros)
| Universe -- the type of types of types (the type of TypeTy) | InterfaceTy
deriving (Eq, Ord) | Universe -- the type of types of types (the type of TypeTy)
deriving (Eq, Ord)
-- | Kinds checking -- | Kinds checking
-- Carp's system is simple enough that we do not need to describe kinds by their airty. -- 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 -- After confirming two tys have either base or higher kind
-- unification checks are sufficient to determine whether their arities are compatible. -- unification checks are sufficient to determine whether their arities are compatible.
data Kind = Base data Kind
| Higher = Base
deriving (Eq, Ord, Show) | Higher
deriving (Eq, Ord, Show)
tyToKind :: Ty -> Kind tyToKind :: Ty -> Kind
tyToKind (StructTy _ _) = Higher tyToKind (StructTy _ _) = Higher
tyToKind (FuncTy _ _ _) = Higher -- the type of functions, consider the (->) constructor in Haskell tyToKind (FuncTy _ _ _) = Higher -- the type of functions, consider the (->) constructor in Haskell
tyToKind (PointerTy _) = Higher tyToKind (PointerTy _) = Higher
tyToKind (RefTy _ _) = Higher -- Refs may also be treated as a data constructor tyToKind (RefTy _ _) = Higher -- Refs may also be treated as a data constructor
tyToKind _ = Base tyToKind _ = Base
-- Exactly like '==' for Ty, but ignore lifetime parameter -- Exactly like '==' for Ty, but ignore lifetime parameter
typeEqIgnoreLifetimes :: Ty -> Ty -> Bool typeEqIgnoreLifetimes :: Ty -> Ty -> Bool
typeEqIgnoreLifetimes (RefTy a _) (RefTy b _) = a == b typeEqIgnoreLifetimes (RefTy a _) (RefTy b _) = a == b
typeEqIgnoreLifetimes (FuncTy argsA retA _) (FuncTy argsB retB _) = typeEqIgnoreLifetimes (FuncTy argsA retA _) (FuncTy argsB retB _) =
all (== True) (zipWith typeEqIgnoreLifetimes argsA argsB) && all (== True) (zipWith typeEqIgnoreLifetimes argsA argsB)
typeEqIgnoreLifetimes retA retB && typeEqIgnoreLifetimes retA retB
typeEqIgnoreLifetimes (StructTy a tyVarsA) (StructTy b tyVarsB) = typeEqIgnoreLifetimes (StructTy a tyVarsA) (StructTy b tyVarsB) =
a == b && a == b
all (== True) (zipWith typeEqIgnoreLifetimes tyVarsA tyVarsB) && all (== True) (zipWith typeEqIgnoreLifetimes tyVarsA tyVarsB)
typeEqIgnoreLifetimes a b = a == b typeEqIgnoreLifetimes a b = a == b
data SumTyCase = SumTyCase { caseName :: String data SumTyCase
, caseMembers :: [(String, Ty)] = SumTyCase
} deriving (Show, Ord, Eq) { caseName :: String,
caseMembers :: [(String, Ty)]
}
deriving (Show, Ord, Eq)
fnOrLambda :: String fnOrLambda :: String
fnOrLambda = fnOrLambda =
@ -92,27 +100,27 @@ fnOrLambda =
_ -> "Fn" -- "λ" _ -> "Fn" -- "λ"
instance Show Ty where instance Show Ty where
show IntTy = "Int" show IntTy = "Int"
show FloatTy = "Float" show FloatTy = "Float"
show DoubleTy = "Double" show DoubleTy = "Double"
show LongTy = "Long" show LongTy = "Long"
show ByteTy = "Byte" show ByteTy = "Byte"
show BoolTy = "Bool" show BoolTy = "Bool"
show StringTy = "String" show StringTy = "String"
show PatternTy = "Pattern" show PatternTy = "Pattern"
show CharTy = "Char" show CharTy = "Char"
show (FuncTy argTys retTy StaticLifetimeTy) = "(" ++ fnOrLambda ++ " [" ++ joinWithComma (map show argTys) ++ "] " ++ show retTy ++ ")" 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 (FuncTy argTys retTy lt) = "(" ++ fnOrLambda ++ " [" ++ joinWithComma (map show argTys) ++ "] " ++ show retTy ++ " " ++ show lt ++ ")"
show (VarTy t) = t show (VarTy t) = t
show UnitTy = "()" show UnitTy = "()"
show ModuleTy = "Module" show ModuleTy = "Module"
show TypeTy = "Type" show TypeTy = "Type"
show InterfaceTy = "Interface" show InterfaceTy = "Interface"
show (StructTy s []) = (show s) show (StructTy s []) = (show s)
show (StructTy s typeArgs) = "(" ++ (show s) ++ " " ++ joinWithSpace (map show typeArgs) ++ ")" show (StructTy s typeArgs) = "(" ++ (show s) ++ " " ++ joinWithSpace (map show typeArgs) ++ ")"
show (ConcreteNameTy name) = name show (ConcreteNameTy name) = name
show (PointerTy p) = "(Ptr " ++ show p ++ ")" show (PointerTy p) = "(Ptr " ++ show p ++ ")"
show (RefTy r lt) = show (RefTy r lt) =
-- case r of -- case r of
-- PointerTy _ -> listView -- PointerTy _ -> listView
-- StructTy _ _ -> listView -- StructTy _ _ -> listView
@ -120,13 +128,13 @@ instance Show Ty where
-- _ -> "&" ++ show r -- _ -> "&" ++ show r
-- where listView = "(Ref " ++ show r ++ ")" -- where listView = "(Ref " ++ show r ++ ")"
"(Ref " ++ show r ++ " " ++ show lt ++ ")" "(Ref " ++ show r ++ " " ++ show lt ++ ")"
show StaticLifetimeTy = "StaticLifetime" show StaticLifetimeTy = "StaticLifetime"
show MacroTy = "Macro" show MacroTy = "Macro"
show DynamicTy = "Dynamic" show DynamicTy = "Dynamic"
showMaybeTy :: Maybe Ty -> String showMaybeTy :: Maybe Ty -> String
showMaybeTy (Just t) = show t showMaybeTy (Just t) = show t
showMaybeTy Nothing = "(missing-type)" showMaybeTy Nothing = "(missing-type)"
isTypeGeneric :: Ty -> Bool isTypeGeneric :: Ty -> Bool
isTypeGeneric (VarTy _) = True isTypeGeneric (VarTy _) = True
@ -139,30 +147,34 @@ isTypeGeneric _ = False
doesTypeContainTyVarWithName :: String -> Ty -> Bool doesTypeContainTyVarWithName :: String -> Ty -> Bool
doesTypeContainTyVarWithName name (VarTy n) = name == n doesTypeContainTyVarWithName name (VarTy n) = name == n
doesTypeContainTyVarWithName name (FuncTy argTys retTy lt) = doesTypeContainTyVarWithName name (FuncTy argTys retTy lt) =
doesTypeContainTyVarWithName name lt || doesTypeContainTyVarWithName name lt
any (doesTypeContainTyVarWithName name) argTys || || any (doesTypeContainTyVarWithName name) argTys
doesTypeContainTyVarWithName name retTy || doesTypeContainTyVarWithName name retTy
doesTypeContainTyVarWithName name (StructTy n tyArgs) = doesTypeContainTyVarWithName name n || any (doesTypeContainTyVarWithName name) tyArgs doesTypeContainTyVarWithName name (StructTy n tyArgs) = doesTypeContainTyVarWithName name n || any (doesTypeContainTyVarWithName name) tyArgs
doesTypeContainTyVarWithName name (PointerTy p) = doesTypeContainTyVarWithName name p doesTypeContainTyVarWithName name (PointerTy p) = doesTypeContainTyVarWithName name p
doesTypeContainTyVarWithName name (RefTy r lt) = doesTypeContainTyVarWithName name r || doesTypeContainTyVarWithName name (RefTy r lt) =
doesTypeContainTyVarWithName name lt doesTypeContainTyVarWithName name r
|| doesTypeContainTyVarWithName name lt
doesTypeContainTyVarWithName _ _ = False doesTypeContainTyVarWithName _ _ = False
replaceConflicted :: String -> Ty -> Ty replaceConflicted :: String -> Ty -> Ty
replaceConflicted name (VarTy n) = if n == name replaceConflicted name (VarTy n) =
then (VarTy (n ++ "conflicted")) if n == name
else (VarTy n) then (VarTy (n ++ "conflicted"))
else (VarTy n)
replaceConflicted name (FuncTy argTys retTy lt) = replaceConflicted name (FuncTy argTys retTy lt) =
FuncTy (map (replaceConflicted name) argTys) FuncTy
(replaceConflicted name retTy) (map (replaceConflicted name) argTys)
(replaceConflicted name lt) (replaceConflicted name retTy)
(replaceConflicted name lt)
replaceConflicted name (StructTy n tyArgs) = StructTy (replaceConflicted name n) (map (replaceConflicted name) tyArgs) replaceConflicted name (StructTy n tyArgs) = StructTy (replaceConflicted name n) (map (replaceConflicted name) tyArgs)
replaceConflicted name (PointerTy p) = PointerTy (replaceConflicted name p) replaceConflicted name (PointerTy p) = PointerTy (replaceConflicted name p)
replaceConflicted name (RefTy r lt) = RefTy (replaceConflicted name r) replaceConflicted name (RefTy r lt) =
(replaceConflicted name lt) RefTy
(replaceConflicted name r)
(replaceConflicted name lt)
replaceConflicted _ t = t replaceConflicted _ t = t
-- | Map type variable names to actual types, eg. t0 => Int, t1 => Float -- | Map type variable names to actual types, eg. t0 => Int, t1 => Float
type TypeMappings = Map.Map String Ty 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 -- create mappings that translate from the type variables to concrete types, e.g. "t0" => Int, "t1" => Bool
unifySignatures :: Ty -> Ty -> TypeMappings unifySignatures :: Ty -> Ty -> TypeMappings
unifySignatures at ct = Map.fromList (unify at ct) unifySignatures at ct = Map.fromList (unify at ct)
where unify :: Ty -> Ty -> [(String, Ty)] where
unify (VarTy _) (VarTy _) = [] -- if a == b then [] else error ("Can't unify " ++ show a ++ " with " ++ show b) 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 (VarTy a) value = [(a, value)]
unify (StructTy v'@(VarTy _) aArgs) (StructTy n bArgs) = unify v' n ++ concat (zipWith unify aArgs bArgs)
unify (StructTy v'@(VarTy _) aArgs) (StructTy n bArgs) = unify v' n ++ concat (zipWith unify aArgs bArgs) unify (StructTy a@(ConcreteNameTy _) aArgs) (StructTy b bArgs)
unify (StructTy a@(ConcreteNameTy _) aArgs) (StructTy b bArgs) | a == b = concat (zipWith unify aArgs bArgs)
| a == b = concat (zipWith unify aArgs bArgs) | otherwise = [] -- error ("Can't unify " ++ a ++ " with " ++ b)
| otherwise = [] -- error ("Can't unify " ++ a ++ " with " ++ b) unify (StructTy _ _) _ = [] -- error ("Can't unify " ++ show a ++ " with " ++ show b)
unify (StructTy _ _) _ = [] -- error ("Can't unify " ++ show a ++ " with " ++ show b) unify (PointerTy a) (PointerTy b) = unify a b
unify (PointerTy _) _ = [] -- error ("Can't unify " ++ show a ++ " with " ++ show b)
unify (PointerTy a) (PointerTy b) = unify a b unify (RefTy a ltA) (RefTy b ltB) = unify a b ++ unify ltA ltB
unify (PointerTy _) _ = [] -- error ("Can't unify " ++ show a ++ " with " ++ show b) unify (RefTy _ _) _ = [] -- error ("Can't unify " ++ show a ++ " with " ++ show b)
unify (FuncTy argTysA retTyA ltA) (FuncTy argTysB retTyB ltB) =
unify (RefTy a ltA) (RefTy b ltB) = unify a b ++ unify ltA ltB let argToks = concat (zipWith unify argTysA argTysB)
unify (RefTy _ _) _ = [] -- error ("Can't unify " ++ show a ++ " with " ++ show b) retToks = unify retTyA retTyB
ltToks = unify ltA ltB
unify (FuncTy argTysA retTyA ltA) (FuncTy argTysB retTyB ltB) = in ltToks ++ argToks ++ retToks
let argToks = concat (zipWith unify argTysA argTysB) unify FuncTy {} _ = [] -- error ("Can't unify " ++ show a ++ " with " ++ show b)
retToks = unify retTyA retTyB unify a b
ltToks = unify ltA ltB | a == b = []
in ltToks ++ argToks ++ retToks | otherwise = [] -- error ("Can't unify " ++ show a ++ " with " ++ show b)
unify FuncTy{} _ = [] -- error ("Can't unify " ++ show a ++ " with " ++ show b)
unify a b | a == b = []
| otherwise = [] -- error ("Can't unify " ++ show a ++ " with " ++ show b)
-- | Checks if two types will unify -- | Checks if two types will unify
areUnifiable :: Ty -> Ty -> Bool areUnifiable :: Ty -> Ty -> Bool
@ -203,8 +212,9 @@ areUnifiable (VarTy _) _ = True
areUnifiable _ (VarTy _) = True areUnifiable _ (VarTy _) = True
areUnifiable (StructTy a aArgs) (StructTy b bArgs) areUnifiable (StructTy a aArgs) (StructTy b bArgs)
| length aArgs /= length bArgs = False | length aArgs /= length bArgs = False
| areUnifiable a b = let argBools = zipWith areUnifiable aArgs bArgs | areUnifiable a b =
in all (== True) argBools let argBools = zipWith areUnifiable aArgs bArgs
in all (== True) argBools
| otherwise = False | otherwise = False
areUnifiable (StructTy (VarTy _) aArgs) (FuncTy bArgs _ _) areUnifiable (StructTy (VarTy _) aArgs) (FuncTy bArgs _ _)
| length aArgs /= length bArgs = False | length aArgs /= length bArgs = False
@ -216,16 +226,18 @@ areUnifiable (StructTy _ _) _ = False
areUnifiable (PointerTy a) (PointerTy b) = areUnifiable a b areUnifiable (PointerTy a) (PointerTy b) = areUnifiable a b
areUnifiable (PointerTy _) _ = False areUnifiable (PointerTy _) _ = False
areUnifiable (RefTy a ltA) (RefTy b ltB) = areUnifiable a b && areUnifiable ltA ltB 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) areUnifiable (FuncTy argTysA retTyA ltA) (FuncTy argTysB retTyB ltB)
| length argTysA /= length argTysB = False | length argTysA /= length argTysB = False
| otherwise = let argBools = zipWith areUnifiable argTysA argTysB | otherwise =
retBool = areUnifiable retTyA retTyB let argBools = zipWith areUnifiable argTysA argTysB
ltBool = areUnifiable ltA ltB retBool = areUnifiable retTyA retTyB
in all (== True) (ltBool : retBool : argBools) ltBool = areUnifiable ltA ltB
areUnifiable FuncTy{} _ = False in all (== True) (ltBool : retBool : argBools)
areUnifiable a b | a == b = True areUnifiable FuncTy {} _ = False
| otherwise = False areUnifiable a b
| a == b = True
| otherwise = False
-- Checks whether or not the kindedness of types match -- Checks whether or not the kindedness of types match
-- Kinds are polymorphic constructors such as (f a) -- Kinds are polymorphic constructors such as (f a)
@ -235,7 +247,7 @@ checkKinds :: Ty -> Ty -> Bool
checkKinds (FuncTy argTysA retTyA _) (FuncTy argTysB retTyB _) = checkKinds (FuncTy argTysA retTyA _) (FuncTy argTysB retTyB _) =
let argKinds = zipWith checkKinds argTysA argTysB let argKinds = zipWith checkKinds argTysA argTysB
retKinds = tyToKind retTyA <= tyToKind retTyB retKinds = tyToKind retTyA <= tyToKind retTyB
in all (== True) (retKinds : argKinds) in all (== True) (retKinds : argKinds)
checkKinds t t' = tyToKind t <= tyToKind t' checkKinds t t' = tyToKind t <= tyToKind t'
-- | Put concrete types into the places where there are type variables. -- | 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) (FuncTy argTys retTy lt) -> FuncTy (map (replaceTyVars mappings) argTys) (replaceTyVars mappings retTy) (replaceTyVars mappings lt)
(StructTy name tyArgs) -> (StructTy name tyArgs) ->
case (replaceTyVars mappings name) of case (replaceTyVars mappings name) of
-- special case, struct (f a b) mapped to (RefTy a lt) -- 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 -- 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 -- 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, -- referred to in other places (e.g. (Fn [(f a b)] a)--without a mapping,
-- a would remain generic here. -- a would remain generic here.
(RefTy a lt) -> (replaceTyVars mappings (RefTy a lt)) (RefTy a lt) -> (replaceTyVars mappings (RefTy a lt))
_ -> StructTy (replaceTyVars mappings name) (fmap (replaceTyVars mappings) tyArgs) _ -> StructTy (replaceTyVars mappings name) (fmap (replaceTyVars mappings) tyArgs)
(PointerTy x) -> PointerTy (replaceTyVars mappings x) (PointerTy x) -> PointerTy (replaceTyVars mappings x)

61
src/TypesToC.hs
View File

@ -1,44 +1,47 @@
module TypesToC ( tyToC module TypesToC
, tyToCLambdaFix ( tyToC,
, tyToCRawFunctionPtrFix) where tyToCLambdaFix,
tyToCRawFunctionPtrFix,
)
where
import Util
import SymPath import SymPath
import Types import Types
import Util
tyToC :: Ty -> String tyToC :: Ty -> String
tyToC = tyToCManglePtr False tyToC = tyToCManglePtr False
tyToCLambdaFix :: Ty -> String tyToCLambdaFix :: Ty -> String
tyToCLambdaFix FuncTy{} = "Lambda" tyToCLambdaFix FuncTy {} = "Lambda"
tyToCLambdaFix (RefTy FuncTy{} _) = "Lambda*" tyToCLambdaFix (RefTy FuncTy {} _) = "Lambda*"
tyToCLambdaFix (RefTy (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 (RefTy (RefTy (RefTy FuncTy {} _) _) _) = "Lambda***" -- TODO: More cases needed?! What's a better way to do it..?
tyToCLambdaFix t = tyToCManglePtr False t tyToCLambdaFix t = tyToCManglePtr False t
tyToCRawFunctionPtrFix :: Ty -> String tyToCRawFunctionPtrFix :: Ty -> String
tyToCRawFunctionPtrFix FuncTy{} = "void*" tyToCRawFunctionPtrFix FuncTy {} = "void*"
tyToCRawFunctionPtrFix t = tyToCManglePtr False t tyToCRawFunctionPtrFix t = tyToCManglePtr False t
tyToCManglePtr :: Bool -> Ty -> String tyToCManglePtr :: Bool -> Ty -> String
tyToCManglePtr _ IntTy = "int" tyToCManglePtr _ IntTy = "int"
tyToCManglePtr _ BoolTy = "bool" tyToCManglePtr _ BoolTy = "bool"
tyToCManglePtr _ FloatTy = "float" tyToCManglePtr _ FloatTy = "float"
tyToCManglePtr _ DoubleTy = "double" tyToCManglePtr _ DoubleTy = "double"
tyToCManglePtr _ LongTy = "Long" tyToCManglePtr _ LongTy = "Long"
tyToCManglePtr _ ByteTy = "uint8_t" tyToCManglePtr _ ByteTy = "uint8_t"
tyToCManglePtr _ StringTy = "String" tyToCManglePtr _ StringTy = "String"
tyToCManglePtr _ PatternTy = "Pattern" tyToCManglePtr _ PatternTy = "Pattern"
tyToCManglePtr _ CharTy = "Char" tyToCManglePtr _ CharTy = "Char"
tyToCManglePtr _ UnitTy = "void" tyToCManglePtr _ UnitTy = "void"
tyToCManglePtr _ (VarTy x) = x tyToCManglePtr _ (VarTy x) = x
tyToCManglePtr _ (FuncTy argTys retTy _) = "Fn__" ++ joinWithUnderscore (map (tyToCManglePtr True) argTys) ++ "_" ++ tyToCManglePtr True retTy tyToCManglePtr _ (FuncTy argTys retTy _) = "Fn__" ++ joinWithUnderscore (map (tyToCManglePtr True) argTys) ++ "_" ++ tyToCManglePtr True retTy
tyToCManglePtr _ ModuleTy = error "Can't emit module type." tyToCManglePtr _ ModuleTy = error "Can't emit module type."
tyToCManglePtr b (PointerTy p) = tyToCManglePtr b p ++ (if b then mangle "*" else "*") 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 b (RefTy r _) = tyToCManglePtr b r ++ (if b then mangle "*" else "*")
tyToCManglePtr _ (StructTy s []) = tyToCManglePtr False s tyToCManglePtr _ (StructTy s []) = tyToCManglePtr False s
tyToCManglePtr _ (StructTy s typeArgs) = tyToCManglePtr False s ++ "__" ++ joinWithUnderscore (map (tyToCManglePtr True) typeArgs) tyToCManglePtr _ (StructTy s typeArgs) = tyToCManglePtr False s ++ "__" ++ joinWithUnderscore (map (tyToCManglePtr True) typeArgs)
tyToCManglePtr _ (ConcreteNameTy name) = mangle name tyToCManglePtr _ (ConcreteNameTy name) = mangle name
tyToCManglePtr _ TypeTy = error "Can't emit the type of types." tyToCManglePtr _ TypeTy = error "Can't emit the type of types."
tyToCManglePtr _ MacroTy = error "Can't emit the type of macros." tyToCManglePtr _ MacroTy = error "Can't emit the type of macros."
tyToCManglePtr _ DynamicTy = error "Can't emit the type of dynamic functions." 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 Data.List
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import qualified Data.Set as Set
import System.Info (os) import System.Info (os)
joinWith :: String -> [String] -> String 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. -- | 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 :: Maybe a -> b -> Either b a
toEither a b = case a of toEither a b = case a of
Just ok -> Right ok Just ok -> Right ok
Nothing -> Left b Nothing -> Left b
replaceChars :: Map.Map Char String -> String -> String replaceChars :: Map.Map Char String -> String -> String
replaceChars dict = concatMap replacer 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 :: Map.Map String String -> String -> String
replaceStrings dict s = fromMaybe s (Map.lookup s dict) 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 :: Eq a => a -> [a] -> [a]
addIfNotPresent x xs = addIfNotPresent x xs =
if x `elem` xs if x `elem` xs
then xs then xs
else xs ++ [x] else xs ++ [x]
remove :: (a -> Bool) -> [a] -> [a] remove :: (a -> Bool) -> [a] -> [a]
remove f = filter (not . f) remove f = filter (not . f)
@ -68,26 +69,26 @@ data Platform = Linux | MacOS | Windows | FreeBSD deriving (Show, Eq)
platform :: Platform platform :: Platform
platform = platform =
case os of case os of
"linux" -> Linux "linux" -> Linux
"darwin" -> MacOS "darwin" -> MacOS
"mingw32" -> Windows "mingw32" -> Windows
"freebsd" -> FreeBSD "freebsd" -> FreeBSD
unionOfSetsInList :: Ord a => [Set.Set a] -> Set.Set a unionOfSetsInList :: Ord a => [Set.Set a] -> Set.Set a
unionOfSetsInList (x:xs) = unionOfSetsInList (x : xs) =
foldl' Set.union x xs foldl' Set.union x xs
unionOfSetsInList [] = unionOfSetsInList [] =
Set.empty Set.empty
intersectionOfSetsInList :: Ord a => [Set.Set a] -> Set.Set a intersectionOfSetsInList :: Ord a => [Set.Set a] -> Set.Set a
intersectionOfSetsInList (x:xs) = intersectionOfSetsInList (x : xs) =
foldl' Set.intersection x xs foldl' Set.intersection x xs
intersectionOfSetsInList [] = intersectionOfSetsInList [] =
Set.empty Set.empty
evenIndices :: [a] -> [a] 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 -- '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 -- 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 -- 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). -- name (usually the name of the function in which the lambda is defined).
lambdaToCName :: String -> Int -> String lambdaToCName :: String -> Int -> String
lambdaToCName name nestLevel = if nestLevel > 0 lambdaToCName name nestLevel =
then name if nestLevel > 0
else "NAKED_LAMBDA" then name
else "NAKED_LAMBDA"
-- Given an integer, create a dummy argument name for it. -- Given an integer, create a dummy argument name for it.
-- Called by XObj producing functions such as addCommand. -- Called by XObj producing functions such as addCommand.

138
src/Validate.hs
View File

@ -1,41 +1,43 @@
module Validate where module Validate where
import Data.List (nubBy, (\\))
import Data.Function (on) import Data.Function (on)
import Data.List ((\\), nubBy)
import TypeError import Lookup
import Obj import Obj
import TypeError
import Types import Types
import Util import Util
import Lookup
{-# ANN validateMembers "HLint: ignore Eta reduce" #-} {-# ANN validateMembers "HLint: ignore Eta reduce" #-}
-- | Make sure that the member declarations in a type definition -- | Make sure that the member declarations in a type definition
-- | Follow the pattern [<name> <type>, <name> <type>, ...] -- | 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. -- | 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 -> [Ty] -> [XObj] -> Either TypeError ()
validateMemberCases typeEnv typeVariables rest = mapM_ visit rest validateMemberCases typeEnv typeVariables rest = mapM_ visit rest
where visit (XObj (Arr membersXObjs) _ _) = where
validateMembers typeEnv typeVariables membersXObjs visit (XObj (Arr membersXObjs) _ _) =
visit xobj = validateMembers typeEnv typeVariables membersXObjs
Left (InvalidSumtypeCase xobj) visit xobj =
Left (InvalidSumtypeCase xobj)
validateMembers :: TypeEnv -> [Ty] -> [XObj] -> Either TypeError () validateMembers :: TypeEnv -> [Ty] -> [XObj] -> Either TypeError ()
validateMembers typeEnv typeVariables membersXObjs = validateMembers typeEnv typeVariables membersXObjs =
checkUnevenMembers >> checkDuplicateMembers >> checkMembers checkUnevenMembers >> checkDuplicateMembers >> checkMembers
where checkUnevenMembers = where
if length membersXObjs `mod` 2 == 0 checkUnevenMembers =
then Right () if length membersXObjs `mod` 2 == 0
else Left (UnevenMembers membersXObjs) then Right ()
pairs = pairwise membersXObjs else Left (UnevenMembers membersXObjs)
fields = fst <$> pairs pairs = pairwise membersXObjs
uniqueFields = nubBy ((==) `on` xobjObj) fields fields = fst <$> pairs
dups = fields \\ uniqueFields uniqueFields = nubBy ((==) `on` xobjObj) fields
checkDuplicateMembers = dups = fields \\ uniqueFields
if length fields == length uniqueFields checkDuplicateMembers =
then Right () if length fields == length uniqueFields
else Left (DuplicatedMembers dups) then Right ()
checkMembers = mapM_ (okXObjForType typeEnv typeVariables . snd) pairs else Left (DuplicatedMembers dups)
checkMembers = mapM_ (okXObjForType typeEnv typeVariables . snd) pairs
-- validateOneCase :: XObj -> a -- validateOneCase :: XObj -> a
-- validateOneCase XObj {} = -- validateOneCase XObj {} =
@ -51,59 +53,65 @@ okXObjForType typeEnv typeVariables xobj =
canBeUsedAsMemberType :: TypeEnv -> [Ty] -> Ty -> XObj -> Either TypeError () canBeUsedAsMemberType :: TypeEnv -> [Ty] -> Ty -> XObj -> Either TypeError ()
canBeUsedAsMemberType typeEnv typeVariables ty xobj = canBeUsedAsMemberType typeEnv typeVariables ty xobj =
case ty of case ty of
UnitTy -> pure () UnitTy -> pure ()
IntTy -> pure () IntTy -> pure ()
FloatTy -> pure () FloatTy -> pure ()
DoubleTy -> pure () DoubleTy -> pure ()
ByteTy -> pure () ByteTy -> pure ()
LongTy -> pure () LongTy -> pure ()
BoolTy -> pure () BoolTy -> pure ()
StringTy -> pure () StringTy -> pure ()
PatternTy -> pure () PatternTy -> pure ()
CharTy -> pure () CharTy -> pure ()
FuncTy{} -> pure () FuncTy {} -> pure ()
PointerTy UnitTy -> pure () PointerTy UnitTy -> pure ()
PointerTy inner -> do _ <- canBeUsedAsMemberType typeEnv typeVariables inner xobj PointerTy inner -> do
pure () _ <- canBeUsedAsMemberType typeEnv typeVariables inner xobj
StructTy (ConcreteNameTy "Array") [inner] -> do _ <- canBeUsedAsMemberType typeEnv typeVariables inner xobj pure ()
pure () StructTy (ConcreteNameTy "Array") [inner] -> do
_ <- canBeUsedAsMemberType typeEnv typeVariables inner xobj
pure ()
StructTy name [tyVars] -> StructTy name [tyVars] ->
case name of case name of
(ConcreteNameTy name') -> (ConcreteNameTy name') ->
-- ensure structs are filled with values -- ensure structs are filled with values
-- Prevents deftypes such as (deftype Player [pos Vector3]) -- Prevents deftypes such as (deftype Player [pos Vector3])
do _ <- canBeUsedAsMemberType typeEnv typeVariables tyVars xobj do
case lookupInEnv (SymPath [] name') (getTypeEnv typeEnv) of _ <- canBeUsedAsMemberType typeEnv typeVariables tyVars xobj
Just _ -> pure () case lookupInEnv (SymPath [] name') (getTypeEnv typeEnv) of
Nothing -> Left (NotAmongRegisteredTypes ty xobj) Just _ -> pure ()
Nothing -> Left (NotAmongRegisteredTypes ty xobj)
-- e.g. (deftype (Higher (f a)) (Of [(f a)])) -- e.g. (deftype (Higher (f a)) (Of [(f a)]))
(VarTy _) -> pure () (VarTy _) -> pure ()
s@(StructTy name tyvar) -> s@(StructTy name tyvar) ->
if isExternalType typeEnv s if isExternalType typeEnv s
then pure () then pure ()
else case name of else case name of
(ConcreteNameTy n) -> (ConcreteNameTy n) ->
case lookupInEnv (SymPath [] n) (getTypeEnv typeEnv) of case lookupInEnv (SymPath [] n) (getTypeEnv typeEnv) of
Just (_, (Binder _ (XObj (Lst (XObj (Deftype t) _ _ : _))_ _))) -> Just (_, (Binder _ (XObj (Lst (XObj (Deftype t) _ _ : _)) _ _))) ->
checkInhabitants t checkInhabitants t
Just (_, (Binder _ (XObj (Lst (XObj (DefSumtype t) _ _ : _))_ _))) -> Just (_, (Binder _ (XObj (Lst (XObj (DefSumtype t) _ _ : _)) _ _))) ->
checkInhabitants t checkInhabitants t
_ -> Left (InvalidMemberType ty xobj) _ -> Left (InvalidMemberType ty xobj)
-- Make sure any struct types have arguments before they can be used as members. where
where checkInhabitants t = -- Make sure any struct types have arguments before they can be used as members.
case t of
(StructTy _ vars) -> checkInhabitants t =
if length vars == length tyvar case t of
then pure () (StructTy _ vars) ->
else Left (UninhabitedConstructor ty xobj (length tyvar) (length vars)) if length vars == length tyvar
_ -> Left (InvalidMemberType ty xobj) then pure ()
_ -> Left (InvalidMemberType ty xobj) else Left (UninhabitedConstructor ty xobj (length tyvar) (length vars))
VarTy _ -> if foldr (||) False (map (isCaptured ty) typeVariables) _ -> Left (InvalidMemberType ty xobj)
then pure () _ -> Left (InvalidMemberType ty xobj)
else Left (InvalidMemberType ty xobj) VarTy _ ->
where if foldr (||) False (map (isCaptured ty) typeVariables)
-- If a variable `a` appears in a higher-order polymorphic form, such as `(f a)` then pure ()
-- `a` may be used as a member, sans `f`. else Left (InvalidMemberType ty xobj)
isCaptured t v@(VarTy _) = t == v where
isCaptured t (StructTy (VarTy _) vars) = any (== t) vars -- 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) _ -> 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.Map as Map
import qualified Data.Set as Set import qualified Data.Set as Set
import Constraints import Eval
import Types import Infer
import Obj import Obj
import Parsing import Parsing
import Infer import Test.HUnit
import Eval import Types
main :: IO () main :: IO ()
main = do _ <- runTestTT (groupTests "Constraints" testConstraints) main = do
return () _ <- runTestTT (groupTests "Constraints" testConstraints)
return ()
groupTests :: String -> [Test] -> Test groupTests :: String -> [Test] -> Test
groupTests label testCases = 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 -- | Helper functions for testing unification of Constraints
isUnificationFailure :: Either UnificationFailure TypeMappings -> Bool isUnificationFailure :: Either UnificationFailure TypeMappings -> Bool
isUnificationFailure (Left _) = True isUnificationFailure (Left _) = True
isUnificationFailure (Right _) = False isUnificationFailure (Right _) = False
assertUnificationFailure :: [Constraint] -> Test assertUnificationFailure :: [Constraint] -> Test
assertUnificationFailure constraints = TestCase $ assertUnificationFailure constraints =
assertBool "Failure" (isUnificationFailure (solve constraints)) TestCase $
assertBool "Failure" (isUnificationFailure (solve constraints))
assertSolution :: [Constraint] -> [(String, Ty)] -> Test assertSolution :: [Constraint] -> [(String, Ty)] -> Test
assertSolution constraints solution = TestCase $ assertSolution constraints solution =
assertEqual "Solution" (Right (Map.fromList solution)) (solve constraints) TestCase $
assertEqual "Solution" (Right (Map.fromList solution)) (solve constraints)
-- | A dummy XObj -- | A dummy XObj
x = XObj (External Nothing) Nothing Nothing x = XObj (External Nothing) Nothing Nothing
-- | Some type variables -- | Some type variables
t0 = VarTy "t0" t0 = VarTy "t0"
t1 = VarTy "t1" t1 = VarTy "t1"
t2 = VarTy "t2" t2 = VarTy "t2"
t3 = VarTy "t3" t3 = VarTy "t3"
-- | Test constraints -- | Test constraints
testConstraints = [testConstr1, testConstr2, testConstr3, testConstr4, testConstr5 testConstraints =
,testConstr6, testConstr7, testConstr8, testConstr9, testConstr10 [ testConstr1,
,testConstr11, testConstr12, testConstr13 testConstr2,
,testConstr20, testConstr21, testConstr22, testConstr23, testConstr24 testConstr3,
-- ,testConstr30 DISABLED FOR NOW, started failing when lifetimes were added to function types TODO: Fix! testConstr4,
,testConstr31, testConstr32, testConstr33 testConstr5,
,testConstr34, testConstr35 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 testConstr1 =
[Constraint FloatTy IntTy x x x OrdNo] assertUnificationFailure
[Constraint FloatTy IntTy x x x OrdNo]
testConstr2 = assertSolution testConstr2 =
[Constraint IntTy t0 x x x OrdNo] assertSolution
[("t0", IntTy)] [Constraint IntTy t0 x x x OrdNo]
[("t0", IntTy)]
testConstr3 = assertSolution testConstr3 =
[Constraint t0 IntTy x x x OrdNo] assertSolution
[("t0", IntTy)] [Constraint t0 IntTy x x x OrdNo]
[("t0", IntTy)]
testConstr4 = assertSolution testConstr4 =
[Constraint t0 t1 x x x OrdNo, Constraint t0 IntTy x x x OrdNo] assertSolution
[("t0", IntTy), ("t1", IntTy)] [Constraint t0 t1 x x x OrdNo, Constraint t0 IntTy x x x OrdNo]
[("t0", IntTy), ("t1", IntTy)]
testConstr5 = assertSolution testConstr5 =
[Constraint t0 t1 x x x OrdNo, Constraint t1 IntTy x x x OrdNo] assertSolution
[("t0", IntTy), ("t1", IntTy)] [Constraint t0 t1 x x x OrdNo, Constraint t1 IntTy x x x OrdNo]
[("t0", IntTy), ("t1", IntTy)]
testConstr6 = assertSolution testConstr6 =
[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] assertSolution
[("t0", IntTy), ("t1", IntTy), ("t2", IntTy), ("t3", IntTy)] [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 testConstr7 =
[Constraint t0 IntTy x x x OrdNo, Constraint t0 FloatTy x x x OrdNo] assertUnificationFailure
[Constraint t0 IntTy x x x OrdNo, Constraint t0 FloatTy x x x OrdNo]
testConstr8 = assertSolution testConstr8 =
[Constraint t0 IntTy x x x OrdNo, Constraint t0 t0 x x x OrdNo] assertSolution
[("t0", IntTy)] [Constraint t0 IntTy x x x OrdNo, Constraint t0 t0 x x x OrdNo]
[("t0", IntTy)]
testConstr9 = assertSolution testConstr9 =
[Constraint t0 IntTy x x x OrdNo, Constraint t0 t1 x x x OrdNo] assertSolution
[("t0", IntTy), ("t1", IntTy)] [Constraint t0 IntTy x x x OrdNo, Constraint t0 t1 x x x OrdNo]
[("t0", IntTy), ("t1", IntTy)]
testConstr10 = assertSolution testConstr10 =
[Constraint (PointerTy (VarTy "a")) (PointerTy (VarTy "b")) x x x OrdNo] assertSolution
[("a", (VarTy "a")), ("b", (VarTy "a"))] [Constraint (PointerTy (VarTy "a")) (PointerTy (VarTy "b")) x x x OrdNo]
[("a", (VarTy "a")), ("b", (VarTy "a"))]
testConstr11 = assertSolution testConstr11 =
[Constraint (PointerTy (VarTy "a")) (PointerTy (StructTy (ConcreteNameTy "Monkey") [])) x x x OrdNo] assertSolution
[("a", (StructTy (ConcreteNameTy "Monkey") []))] [Constraint (PointerTy (VarTy "a")) (PointerTy (StructTy (ConcreteNameTy "Monkey") [])) x x x OrdNo]
[("a", (StructTy (ConcreteNameTy "Monkey") []))]
testConstr12 = assertSolution testConstr12 =
[Constraint t1 (PointerTy (StructTy (ConcreteNameTy "Array") [IntTy])) x x x OrdNo assertSolution
,Constraint t1 (PointerTy t2) x x x OrdNo] [ Constraint t1 (PointerTy (StructTy (ConcreteNameTy "Array") [IntTy])) x x x OrdNo,
[("t1", (PointerTy (StructTy (ConcreteNameTy "Array") [IntTy]))) Constraint t1 (PointerTy t2) x x x OrdNo
,("t2", (StructTy (ConcreteNameTy "Array") [IntTy]))] ]
[ ("t1", (PointerTy (StructTy (ConcreteNameTy "Array") [IntTy]))),
("t2", (StructTy (ConcreteNameTy "Array") [IntTy]))
]
testConstr13 = assertSolution testConstr13 =
[Constraint t1 CharTy x x x OrdNo assertSolution
,Constraint t1 CharTy x x x OrdNo] [ Constraint t1 CharTy x x x OrdNo,
[("t1", CharTy)] Constraint t1 CharTy x x x OrdNo
]
[("t1", CharTy)]
-- -- Should collapse type variables into minimal set: -- -- Should collapse type variables into minimal set:
-- testConstr10 = assertSolution -- testConstr10 = assertSolution
@ -108,87 +148,109 @@ testConstr13 = assertSolution
-- m7 = solve ([Constraint t1 t2 x x x, Constraint t0 t1 x x x OrdNo]) -- m7 = solve ([Constraint t1 t2 x x x, Constraint t0 t1 x x x OrdNo])
-- Struct types -- Struct types
testConstr20 = assertSolution testConstr20 =
[Constraint t0 (StructTy (ConcreteNameTy "Vector") [t1]) x x x OrdNo assertSolution
,Constraint t0 (StructTy (ConcreteNameTy "Vector") [IntTy]) x x x OrdNo] [ Constraint t0 (StructTy (ConcreteNameTy "Vector") [t1]) x x x OrdNo,
[("t0", (StructTy (ConcreteNameTy "Vector") [IntTy])), ("t1", IntTy)] Constraint t0 (StructTy (ConcreteNameTy "Vector") [IntTy]) x x x OrdNo
]
[("t0", (StructTy (ConcreteNameTy "Vector") [IntTy])), ("t1", IntTy)]
testConstr21 = assertSolution testConstr21 =
[Constraint t1 (StructTy (ConcreteNameTy "Array") [t2]) x x x OrdNo assertSolution
,Constraint t1 (StructTy (ConcreteNameTy "Array") [t3]) x x x OrdNo [ Constraint t1 (StructTy (ConcreteNameTy "Array") [t2]) x x x OrdNo,
,Constraint t3 BoolTy x x x OrdNo] Constraint t1 (StructTy (ConcreteNameTy "Array") [t3]) x x x OrdNo,
[("t1", (StructTy (ConcreteNameTy "Array") [BoolTy])) Constraint t3 BoolTy x x x OrdNo
,("t2", BoolTy) ]
,("t3", BoolTy)] [ ("t1", (StructTy (ConcreteNameTy "Array") [BoolTy])),
("t2", BoolTy),
("t3", BoolTy)
]
testConstr22 = assertSolution testConstr22 =
[Constraint t1 (StructTy (ConcreteNameTy "Array") [t2]) x x x OrdNo assertSolution
,Constraint t2 (StructTy (ConcreteNameTy "Array") [t3]) x x x OrdNo [ Constraint t1 (StructTy (ConcreteNameTy "Array") [t2]) x x x OrdNo,
,Constraint t3 FloatTy x x x OrdNo] Constraint t2 (StructTy (ConcreteNameTy "Array") [t3]) x x x OrdNo,
[("t1", (StructTy (ConcreteNameTy "Array") [(StructTy (ConcreteNameTy "Array") [FloatTy])])) Constraint t3 FloatTy x x x OrdNo
,("t2", (StructTy (ConcreteNameTy "Array") [FloatTy])) ]
,("t3", FloatTy)] [ ("t1", (StructTy (ConcreteNameTy "Array") [(StructTy (ConcreteNameTy "Array") [FloatTy])])),
("t2", (StructTy (ConcreteNameTy "Array") [FloatTy])),
("t3", FloatTy)
]
testConstr23 = assertUnificationFailure testConstr23 =
[Constraint (StructTy (ConcreteNameTy "Array") [t1]) (StructTy (ConcreteNameTy "Array") [t2]) x x x OrdNo assertUnificationFailure
,Constraint t1 IntTy x x x OrdNo [ Constraint (StructTy (ConcreteNameTy "Array") [t1]) (StructTy (ConcreteNameTy "Array") [t2]) x x x OrdNo,
,Constraint t2 FloatTy x x x OrdNo] Constraint t1 IntTy x x x OrdNo,
Constraint t2 FloatTy x x x OrdNo
]
testConstr24 = assertUnificationFailure testConstr24 =
[Constraint t2 FloatTy x x x OrdNo assertUnificationFailure
,Constraint t1 IntTy x x x OrdNo [ Constraint t2 FloatTy x x x OrdNo,
,Constraint (StructTy (ConcreteNameTy "Array") [t1]) (StructTy (ConcreteNameTy "Array") [t2]) 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] -- 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] -- m10 = solve [Constraint (StructTy "Vector" [t1]) (StructTy "Vector" [t2]) x x x OrdNo]
-- Func types -- Func types
testConstr30 = assertSolution testConstr30 =
[Constraint t2 (FuncTy [t0] t1 StaticLifetimeTy) x x x OrdNo assertSolution
,Constraint t2 (FuncTy [IntTy] BoolTy StaticLifetimeTy) x x x OrdNo] [ Constraint t2 (FuncTy [t0] t1 StaticLifetimeTy) x x x OrdNo,
[("t0", IntTy), ("t1", BoolTy), ("t2", (FuncTy [IntTy] BoolTy StaticLifetimeTy))] Constraint t2 (FuncTy [IntTy] BoolTy StaticLifetimeTy) x x x OrdNo
]
[("t0", IntTy), ("t1", BoolTy), ("t2", (FuncTy [IntTy] BoolTy StaticLifetimeTy))]
testConstr31 = assertSolution testConstr31 =
[Constraint (FuncTy [t0] t1 StaticLifetimeTy) (FuncTy [IntTy] BoolTy StaticLifetimeTy) x x x OrdNo] assertSolution
[("t0", IntTy), ("t1", BoolTy)] [Constraint (FuncTy [t0] t1 StaticLifetimeTy) (FuncTy [IntTy] BoolTy StaticLifetimeTy) x x x OrdNo]
[("t0", IntTy), ("t1", BoolTy)]
testConstr32 = assertSolution testConstr32 =
[Constraint t0 (FuncTy [IntTy] BoolTy StaticLifetimeTy) x x x OrdNo] assertSolution
[("t0", (FuncTy [IntTy] BoolTy StaticLifetimeTy))] [Constraint t0 (FuncTy [IntTy] BoolTy StaticLifetimeTy) x x x OrdNo]
[("t0", (FuncTy [IntTy] BoolTy StaticLifetimeTy))]
testConstr33 = assertSolution testConstr33 =
[Constraint t1 (FuncTy [t2] IntTy StaticLifetimeTy) x x x OrdNo assertSolution
,Constraint t1 (FuncTy [t3] IntTy StaticLifetimeTy) x x x OrdNo [ Constraint t1 (FuncTy [t2] IntTy StaticLifetimeTy) x x x OrdNo,
,Constraint t3 BoolTy x x x OrdNo] Constraint t1 (FuncTy [t3] IntTy StaticLifetimeTy) x x x OrdNo,
[("t1", (FuncTy [BoolTy] IntTy StaticLifetimeTy)) Constraint t3 BoolTy x x x OrdNo
,("t2", BoolTy) ]
,("t3", BoolTy)] [ ("t1", (FuncTy [BoolTy] IntTy StaticLifetimeTy)),
("t2", BoolTy),
("t3", BoolTy)
]
testConstr34 = assertSolution testConstr34 =
[Constraint (VarTy "a") (StructTy (ConcreteNameTy "Pair") [(VarTy "x0"), (VarTy "y0")]) x x x OrdNo assertSolution
,Constraint (StructTy (ConcreteNameTy "Array") [(VarTy "a")]) (StructTy (ConcreteNameTy "Array") [(StructTy (ConcreteNameTy "Pair") [(VarTy "x1"), (VarTy "y1")])]) x x x OrdNo] [ Constraint (VarTy "a") (StructTy (ConcreteNameTy "Pair") [(VarTy "x0"), (VarTy "y0")]) x x x OrdNo,
[("a", (StructTy (ConcreteNameTy "Pair") [(VarTy "x0"), (VarTy "y0")])) Constraint (StructTy (ConcreteNameTy "Array") [(VarTy "a")]) (StructTy (ConcreteNameTy "Array") [(StructTy (ConcreteNameTy "Pair") [(VarTy "x1"), (VarTy "y1")])]) x x x OrdNo
,("x0", (VarTy "x0")) ]
,("y0", (VarTy "y0")) [ ("a", (StructTy (ConcreteNameTy "Pair") [(VarTy "x0"), (VarTy "y0")])),
,("x1", (VarTy "x0")) ("x0", (VarTy "x0")),
,("y1", (VarTy "y0")) ("y0", (VarTy "y0")),
] ("x1", (VarTy "x0")),
("y1", (VarTy "y0"))
]
-- Same as testConstr34, except everything is wrapped in refs -- Same as testConstr34, except everything is wrapped in refs
testConstr35 = assertSolution testConstr35 =
[Constraint (RefTy (VarTy "a") (VarTy "lt0")) (RefTy (StructTy (ConcreteNameTy "Pair") [(VarTy "x0"), (VarTy "y0")]) (VarTy "lt1")) x x x OrdNo assertSolution
,Constraint (RefTy (StructTy (ConcreteNameTy "Array") [(VarTy "a")]) (VarTy "lt2")) (RefTy (StructTy (ConcreteNameTy "Array") [(StructTy (ConcreteNameTy "Pair") [(VarTy "x1"), (VarTy "y1")])]) (VarTy "lt3")) x x x OrdNo] [ Constraint (RefTy (VarTy "a") (VarTy "lt0")) (RefTy (StructTy (ConcreteNameTy "Pair") [(VarTy "x0"), (VarTy "y0")]) (VarTy "lt1")) x x x OrdNo,
[("a", (StructTy (ConcreteNameTy "Pair") [(VarTy "x0"), (VarTy "y0")])) 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
,("x0", (VarTy "x0")) ]
,("y0", (VarTy "y0")) [ ("a", (StructTy (ConcreteNameTy "Pair") [(VarTy "x0"), (VarTy "y0")])),
,("x1", (VarTy "x0")) ("x0", (VarTy "x0")),
,("y1", (VarTy "y0")) ("y0", (VarTy "y0")),
,("lt0", (VarTy "lt0")) ("x1", (VarTy "x0")),
,("lt1", (VarTy "lt0")) ("y1", (VarTy "y0")),
,("lt2", (VarTy "lt2")) ("lt0", (VarTy "lt0")),
,("lt3", (VarTy "lt2")) ("lt1", (VarTy "lt0")),
] ("lt2", (VarTy "lt2")),
("lt3", (VarTy "lt2"))
]
-- Ref types with lifetimes -- Ref types with lifetimes
-- testConstr36 = assertSolution -- testConstr36 = assertSolution
-- [Constraint (RefTy (VarTy "a")) (RefTy (StructTy "Pair" [(VarTy "x0"), (VarTy "y0")])) x x x OrdNo -- [Constraint (RefTy (VarTy "a")) (RefTy (StructTy "Pair" [(VarTy "x0"), (VarTy "y0")])) x x x OrdNo