mirror of
https://github.com/carp-lang/Carp.git
synced 2024-09-11 05:25:28 +03:00
chore: Re-format Haskell code (#1219)
* chore: Re-format Haskell code * fix: Re-add comment
This commit is contained in:
parent
085089e293
commit
0bb32ab0e6
@ -11,6 +11,7 @@ import Data.Maybe (fromMaybe)
|
||||
import Debug.Trace
|
||||
import Env (envIsExternal, findPoly, getTypeBinder, getValue, insert, insertX, lookupEverywhere, searchValue)
|
||||
import Info
|
||||
import InitialTypes
|
||||
import Managed
|
||||
import qualified Map
|
||||
import Obj
|
||||
@ -27,7 +28,6 @@ import TypesToC
|
||||
import Util
|
||||
import Validate
|
||||
import Prelude hiding (lookup)
|
||||
import InitialTypes
|
||||
|
||||
data Level = Toplevel | Inside
|
||||
|
||||
@ -89,8 +89,8 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
|
||||
envWithArgs =
|
||||
foldl'
|
||||
( \e arg@(XObj (Sym path _) _ _) ->
|
||||
-- n.b. this won't fail since we're inserting unqualified args into a fresh env
|
||||
-- TODO: Still, it'd be nicer and more flexible to catch failures here.
|
||||
-- n.b. this won't fail since we're inserting unqualified args into a fresh env
|
||||
-- TODO: Still, it'd be nicer and more flexible to catch failures here.
|
||||
let Right v = insertX e path arg in v
|
||||
)
|
||||
functionEnv
|
||||
@ -490,12 +490,12 @@ renameGenericTypeSymbolsOnSum varpairs x@(XObj (Lst (caseNm : caseMembers)) i t)
|
||||
where
|
||||
mapp = Map.fromList varpairs
|
||||
replacer mem@(XObj (Sym (SymPath [] name) _) _ _) =
|
||||
let Just perhapsTyVar = xobjToTy mem
|
||||
in if isFullyGenericType perhapsTyVar
|
||||
then case Map.lookup (VarTy name) mapp of
|
||||
Just new -> reify new
|
||||
_ -> mem
|
||||
else mem
|
||||
let Just perhapsTyVar = xobjToTy mem
|
||||
in if isFullyGenericType perhapsTyVar
|
||||
then case Map.lookup (VarTy name) mapp of
|
||||
Just new -> reify new
|
||||
_ -> mem
|
||||
else mem
|
||||
replacer y = y
|
||||
renameGenericTypeSymbolsOnSum _ x = x
|
||||
|
||||
@ -503,11 +503,12 @@ renameGenericTypeSymbolsOnSum _ x = x
|
||||
renameGenericTypeSymbolsOnProduct :: [Ty] -> [XObj] -> [XObj]
|
||||
renameGenericTypeSymbolsOnProduct vars members =
|
||||
concatMap (\(var, (v, t)) -> [v, rename var t]) (zip vars (pairwise members))
|
||||
where rename var mem =
|
||||
let Just perhapsTyVar = xobjToTy mem
|
||||
in if isFullyGenericType perhapsTyVar
|
||||
then reify var
|
||||
else mem
|
||||
where
|
||||
rename var mem =
|
||||
let Just perhapsTyVar = xobjToTy mem
|
||||
in if isFullyGenericType perhapsTyVar
|
||||
then reify var
|
||||
else mem
|
||||
|
||||
-- | Given an generic struct type and a concrete version of it, generate all dependencies needed to use the concrete one.
|
||||
-- TODO: Handle polymorphic constructors (a b).
|
||||
@ -525,9 +526,9 @@ instantiateGenericStructType typeEnv originalStructTy@(StructTy _ _) genericStru
|
||||
nameFixedMembers = renameGenericTypeSymbolsOnProduct renamedOrig memberXObjs
|
||||
validMembers = replaceGenericTypeSymbolsOnMembers mapp nameFixedMembers
|
||||
concretelyTypedMembers = replaceGenericTypeSymbolsOnMembers mappings memberXObjs
|
||||
-- We only used the renamed types for validation--passing the
|
||||
-- renamed xobjs further down leads to syntactical issues.
|
||||
in case validateMembers typeEnv renamedOrig validMembers of
|
||||
in -- We only used the renamed types for validation--passing the
|
||||
-- renamed xobjs further down leads to syntactical issues.
|
||||
case validateMembers typeEnv renamedOrig validMembers of
|
||||
Left err -> Left err
|
||||
Right () ->
|
||||
let deps = mapM (depsForStructMemberPair typeEnv) (pairwise concretelyTypedMembers)
|
||||
|
40
src/Eval.hs
40
src/Eval.hs
@ -42,7 +42,7 @@ data LookupPreference
|
||||
= PreferDynamic
|
||||
| PreferGlobal
|
||||
| PreferLocal [SymPath]
|
||||
deriving Show
|
||||
deriving (Show)
|
||||
|
||||
data Resolver
|
||||
= ResolveGlobal
|
||||
@ -78,7 +78,7 @@ eval ctx xobj@(XObj o info ty) preference resolver =
|
||||
pure $
|
||||
case resolver of
|
||||
ResolveGlobal -> unwrapLookup ((tryAllLookups preference) >>= checkStatic)
|
||||
ResolveLocal -> unwrapLookup (tryAllLookups preference)
|
||||
ResolveLocal -> unwrapLookup (tryAllLookups preference)
|
||||
where
|
||||
checkStatic v@(_, Right (XObj (Lst ((XObj obj _ _) : _)) _ _)) =
|
||||
if isResolvableStaticObj obj
|
||||
@ -89,30 +89,34 @@ eval ctx xobj@(XObj o info ty) preference resolver =
|
||||
unwrapLookup =
|
||||
fromMaybe
|
||||
(throwErr (SymbolNotFound spath) ctx info)
|
||||
-- | Try all lookups performs lookups for symbols based on a given
|
||||
-- Try all lookups performs lookups for symbols based on a given
|
||||
-- lookup preference.
|
||||
tryAllLookups :: LookupPreference -> Maybe (Context, Either EvalError XObj)
|
||||
tryAllLookups PreferDynamic = (getDynamic) <|> fullLookup
|
||||
tryAllLookups PreferGlobal = (getGlobal spath) <|> fullLookup
|
||||
tryAllLookups PreferGlobal = (getGlobal spath) <|> fullLookup
|
||||
tryAllLookups (PreferLocal shadows) = (if spath `elem` shadows then (getLocal n) else (getDynamic)) <|> fullLookup
|
||||
fullLookup = (tryDynamicLookup <|> (if null p then tryInternalLookup spath <|> tryLookup spath else tryLookup spath))
|
||||
getDynamic :: Maybe (Context, Either EvalError XObj)
|
||||
getDynamic =
|
||||
do (Binder _ found) <- maybeId (E.findValueBinder (contextGlobalEnv ctx) (SymPath ("Dynamic" : p) n))
|
||||
pure (ctx, Right (resolveDef found))
|
||||
do
|
||||
(Binder _ found) <- maybeId (E.findValueBinder (contextGlobalEnv ctx) (SymPath ("Dynamic" : p) n))
|
||||
pure (ctx, Right (resolveDef found))
|
||||
getGlobal :: SymPath -> Maybe (Context, Either EvalError XObj)
|
||||
getGlobal path =
|
||||
do (Binder meta found) <- maybeId (E.findValueBinder (contextGlobalEnv ctx) path)
|
||||
checkPrivate meta found
|
||||
do
|
||||
(Binder meta found) <- maybeId (E.findValueBinder (contextGlobalEnv ctx) path)
|
||||
checkPrivate meta found
|
||||
tryDynamicLookup :: Maybe (Context, Either EvalError XObj)
|
||||
tryDynamicLookup =
|
||||
do (Binder meta found) <- maybeId (E.searchValueBinder (contextGlobalEnv ctx) (SymPath ("Dynamic" : p) n))
|
||||
checkPrivate meta found
|
||||
do
|
||||
(Binder meta found) <- maybeId (E.searchValueBinder (contextGlobalEnv ctx) (SymPath ("Dynamic" : p) n))
|
||||
checkPrivate meta found
|
||||
getLocal :: String -> Maybe (Context, Either EvalError XObj)
|
||||
getLocal name =
|
||||
do internal <- contextInternalEnv ctx
|
||||
(Binder _ found) <- maybeId (E.getValueBinder internal name)
|
||||
pure (ctx, Right (resolveDef found))
|
||||
do
|
||||
internal <- contextInternalEnv ctx
|
||||
(Binder _ found) <- maybeId (E.getValueBinder internal name)
|
||||
pure (ctx, Right (resolveDef found))
|
||||
-- TODO: Deprecate this function?
|
||||
-- The behavior here is a bit nefarious since it relies on cached
|
||||
-- environment parents (it calls `search` on the "internal" binder).
|
||||
@ -446,7 +450,7 @@ macroExpand ctx xobj =
|
||||
ok <- expanded
|
||||
Right (XObj (StaticArr ok) i t)
|
||||
)
|
||||
XObj (Lst (XObj (Sym (SymPath [] "defmodule") _) _ _: _)) _ _ ->
|
||||
XObj (Lst (XObj (Sym (SymPath [] "defmodule") _) _ _ : _)) _ _ ->
|
||||
pure (ctx, Right xobj)
|
||||
XObj (Lst [XObj (Sym (SymPath [] "quote") _) _ _, _]) _ _ ->
|
||||
pure (ctx, Right xobj)
|
||||
@ -1091,9 +1095,11 @@ specialCommandSet ctx [orig@(XObj (Sym path@(SymPath _ _) _) _ _), val] =
|
||||
case result of
|
||||
Right evald -> typeCheckValueAgainstBinder newCtx evald binder >>= \(nctx, typedVal) -> setter nctx env typedVal binder
|
||||
left -> pure (newCtx, left)
|
||||
where handleUnTyped :: IO (Context, Either EvalError XObj)
|
||||
handleUnTyped = evalDynamic ResolveLocal ctx val
|
||||
>>= \(newCtx, result) -> setter newCtx env result binder
|
||||
where
|
||||
handleUnTyped :: IO (Context, Either EvalError XObj)
|
||||
handleUnTyped =
|
||||
evalDynamic ResolveLocal ctx val
|
||||
>>= \(newCtx, result) -> setter newCtx env result binder
|
||||
setGlobal :: Context -> Env -> Either EvalError XObj -> Binder -> IO (Context, Either EvalError XObj)
|
||||
setGlobal ctx' env value binder =
|
||||
pure $ either (failure ctx' orig) (success ctx') value
|
||||
|
@ -1,16 +1,16 @@
|
||||
module Expand (expandAll, replaceSourceInfoOnXObj) where
|
||||
|
||||
import Context
|
||||
import Control.Monad.State (State, evalState, get, put)
|
||||
import Data.Foldable (foldlM)
|
||||
import Env
|
||||
import EvalError
|
||||
import Info
|
||||
import Obj
|
||||
import Qualify
|
||||
import TypeError
|
||||
import Types
|
||||
import Util
|
||||
import Context
|
||||
import Qualify
|
||||
import EvalError
|
||||
|
||||
-- | Used for calling back to the 'eval' function in Eval.hs
|
||||
type DynamicEvaluator = Context -> XObj -> IO (Context, Either EvalError XObj)
|
||||
|
@ -117,15 +117,16 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
|
||||
unknown -> pure (Left (InvalidObj unknown xobj))
|
||||
visitSymbol :: Env -> XObj -> SymPath -> State Integer (Either TypeError XObj)
|
||||
visitSymbol e xobj@(XObj (Sym name LookupRecursive) _ _) _ =
|
||||
case E.searchValueBinder e name of
|
||||
-- If this recursive symbol is already typed in this environment, use that type.
|
||||
-- This is relevant for, e.g. recursive function calls.
|
||||
-- We need to use search here to check parents as our let-binding handling possibly puts recursive
|
||||
-- environments as the parent of a more local environment for the let bindings.
|
||||
Right (Binder _ found) -> pure (Right xobj {xobjTy = xobjTy found})
|
||||
-- Other recursive lookups are left untouched (this avoids problems with looking up the thing they're referring to)
|
||||
Left _ -> do freshTy <- genVarTy
|
||||
pure (Right xobj {xobjTy = Just freshTy})
|
||||
case E.searchValueBinder e name of
|
||||
-- If this recursive symbol is already typed in this environment, use that type.
|
||||
-- This is relevant for, e.g. recursive function calls.
|
||||
-- We need to use search here to check parents as our let-binding handling possibly puts recursive
|
||||
-- environments as the parent of a more local environment for the let bindings.
|
||||
Right (Binder _ found) -> pure (Right xobj {xobjTy = xobjTy found})
|
||||
-- Other recursive lookups are left untouched (this avoids problems with looking up the thing they're referring to)
|
||||
Left _ -> do
|
||||
freshTy <- genVarTy
|
||||
pure (Right xobj {xobjTy = Just freshTy})
|
||||
visitSymbol env xobj symPath =
|
||||
case symPath of
|
||||
-- Symbols with leading ? are 'holes'.
|
||||
|
@ -646,8 +646,8 @@ primitiveUse xobj ctx (XObj (Sym path _) _ _) =
|
||||
-- Look up the module to see if we can actually use it.
|
||||
-- The reference might be contextual, if so, append the current context path strings.
|
||||
path' = case (searchValueBinder global path) of
|
||||
Right _ -> path
|
||||
_ -> contextualized
|
||||
Right _ -> path
|
||||
_ -> contextualized
|
||||
in pure
|
||||
( case modulePath of
|
||||
(SymPath [] "") -> updateGlobalUsePaths global path'
|
||||
|
Loading…
Reference in New Issue
Block a user