mirror of
https://github.com/carp-lang/Carp.git
synced 2024-09-11 05:25:28 +03:00
fix: Bumped Ormolu version to 0.1.4.1 (#1050)
This commit is contained in:
parent
fa29e8f464
commit
a152a0d6e1
32
app/Main.hs
32
app/Main.hs
@ -156,14 +156,13 @@ main = do
|
||||
pure ()
|
||||
|
||||
-- | Options for how to run the compiler.
|
||||
data FullOptions
|
||||
= FullOptions
|
||||
{ optExecMode :: ExecutionMode,
|
||||
optOthers :: OtherOptions,
|
||||
optPreload :: [String],
|
||||
optPostload :: [String],
|
||||
optFiles :: [FilePath]
|
||||
}
|
||||
data FullOptions = FullOptions
|
||||
{ optExecMode :: ExecutionMode,
|
||||
optOthers :: OtherOptions,
|
||||
optPreload :: [String],
|
||||
optPostload :: [String],
|
||||
optFiles :: [FilePath]
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
parseFull :: Parser FullOptions
|
||||
@ -175,15 +174,14 @@ parseFull =
|
||||
<*> many (strOption (long "eval-postload" <> metavar "CODE" <> help "Eval CODE after loading FILES"))
|
||||
<*> parseFiles
|
||||
|
||||
data OtherOptions
|
||||
= OtherOptions
|
||||
{ otherNoCore :: Bool,
|
||||
otherNoProfile :: Bool,
|
||||
otherLogMemory :: Bool,
|
||||
otherOptimize :: Bool,
|
||||
otherGenerateOnly :: Bool,
|
||||
otherPrompt :: Maybe String
|
||||
}
|
||||
data OtherOptions = OtherOptions
|
||||
{ otherNoCore :: Bool,
|
||||
otherNoProfile :: Bool,
|
||||
otherLogMemory :: Bool,
|
||||
otherOptimize :: Bool,
|
||||
otherGenerateOnly :: Bool,
|
||||
otherPrompt :: Maybe String
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
parseOther :: Parser OtherOptions
|
||||
|
@ -13,12 +13,11 @@ import qualified Text.Parsec as Parsec
|
||||
import Types
|
||||
import Util
|
||||
|
||||
data Args
|
||||
= Args
|
||||
{ prefixToRemove :: String,
|
||||
kebabCase :: Bool,
|
||||
sourcePath :: String
|
||||
}
|
||||
data Args = Args
|
||||
{ prefixToRemove :: String,
|
||||
kebabCase :: Bool,
|
||||
sourcePath :: String
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
parseArgs :: Parser Args
|
||||
|
@ -61,22 +61,23 @@ templateEFilter = defineTypeParameterizedTemplate templateCreator path t docs
|
||||
t
|
||||
(const (toTemplate "Array $NAME(Lambda *predicate, Array a)")) -- Lambda used to be $(Fn [(Ref a)] Bool)
|
||||
( \(FuncTy [RefTy (FuncTy [RefTy insideTy _] BoolTy _) _, _] _ _) ->
|
||||
toTemplate $ unlines $
|
||||
let deleter = insideArrayDeletion typeEnv env insideTy
|
||||
in [ "$DECL { ",
|
||||
" int insertIndex = 0;",
|
||||
" for(int i = 0; i < a.len; ++i) {",
|
||||
" if(" ++ templateCodeForCallingLambda "(*predicate)" fTy [elt] ++ ") {",
|
||||
" ((($a*)a.data)[insertIndex++]) = (($a*)a.data)[i];",
|
||||
" } else {",
|
||||
" " ++ deleter "i",
|
||||
" }",
|
||||
" }",
|
||||
" a.len = insertIndex;",
|
||||
templateShrinkCheck "a",
|
||||
" return a;",
|
||||
"}"
|
||||
]
|
||||
toTemplate $
|
||||
unlines $
|
||||
let deleter = insideArrayDeletion typeEnv env insideTy
|
||||
in [ "$DECL { ",
|
||||
" int insertIndex = 0;",
|
||||
" for(int i = 0; i < a.len; ++i) {",
|
||||
" if(" ++ templateCodeForCallingLambda "(*predicate)" fTy [elt] ++ ") {",
|
||||
" ((($a*)a.data)[insertIndex++]) = (($a*)a.data)[i];",
|
||||
" } else {",
|
||||
" " ++ deleter "i",
|
||||
" }",
|
||||
" }",
|
||||
" a.len = insertIndex;",
|
||||
templateShrinkCheck "a",
|
||||
" return a;",
|
||||
"}"
|
||||
]
|
||||
)
|
||||
( \(FuncTy [RefTy ft@(FuncTy fArgTys@[RefTy insideType _] BoolTy _) _, _] _ _) ->
|
||||
[defineFunctionTypeAlias ft, defineFunctionTypeAlias (FuncTy (lambdaEnvTy : fArgTys) BoolTy StaticLifetimeTy)]
|
||||
|
@ -772,10 +772,10 @@ commandSexpressionInternal ctx [xobj] bol =
|
||||
bindingSyms e (ctx, Right x)
|
||||
where
|
||||
bindingSyms env start =
|
||||
( mapM (\x -> commandSexpression ctx [x])
|
||||
$ map snd
|
||||
$ Map.toList
|
||||
$ Map.map binderXObj (envBindings env)
|
||||
( mapM (\x -> commandSexpression ctx [x]) $
|
||||
map snd $
|
||||
Map.toList $
|
||||
Map.map binderXObj (envBindings env)
|
||||
)
|
||||
>>= pure . foldl combine start
|
||||
combine (c, (Right (XObj (Lst xs) i t))) (_, (Right y@(XObj (Lst _) _ _))) =
|
||||
|
@ -8,8 +8,8 @@ import Control.Monad.State
|
||||
import Data.List (foldl')
|
||||
import qualified Data.Map as Map
|
||||
import Data.Maybe (fromMaybe)
|
||||
import qualified Data.Set as Set
|
||||
import Data.Set ((\\))
|
||||
import qualified Data.Set as Set
|
||||
import Debug.Trace
|
||||
import Info
|
||||
import Lookup
|
||||
@ -133,15 +133,15 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
|
||||
extendedArgs =
|
||||
if null capturedVars
|
||||
then args
|
||||
else-- If the lambda captures anything it need an extra arg for its env:
|
||||
else -- If the lambda captures anything it need an extra arg for its env:
|
||||
|
||||
XObj
|
||||
( Arr
|
||||
( XObj
|
||||
(Sym (SymPath [] "_env") Symbol)
|
||||
(Just dummyInfo)
|
||||
(Just (PointerTy (StructTy (ConcreteNameTy environmentTypeName) [])))
|
||||
: argsArr
|
||||
(Just (PointerTy (StructTy (ConcreteNameTy environmentTypeName) []))) :
|
||||
argsArr
|
||||
)
|
||||
)
|
||||
ai
|
||||
@ -487,14 +487,14 @@ instantiateGenericStructType typeEnv originalStructTy@(StructTy _ originalTyVars
|
||||
Right $
|
||||
XObj
|
||||
( Lst
|
||||
( XObj (Deftype genericStructTy) Nothing Nothing
|
||||
: XObj (Sym (SymPath [] (tyToC genericStructTy)) Symbol) Nothing Nothing
|
||||
: [XObj (Arr concretelyTypedMembers) Nothing Nothing]
|
||||
( XObj (Deftype genericStructTy) Nothing Nothing :
|
||||
XObj (Sym (SymPath [] (tyToC genericStructTy)) Symbol) Nothing Nothing :
|
||||
[XObj (Arr concretelyTypedMembers) Nothing Nothing]
|
||||
)
|
||||
)
|
||||
(Just dummyInfo)
|
||||
(Just TypeTy)
|
||||
: concat okDeps
|
||||
(Just TypeTy) :
|
||||
concat okDeps
|
||||
|
||||
depsForStructMemberPair :: TypeEnv -> (XObj, XObj) -> Either TypeError [XObj]
|
||||
depsForStructMemberPair typeEnv (_, tyXObj) =
|
||||
@ -521,14 +521,14 @@ instantiateGenericSumtype typeEnv originalStructTy@(StructTy _ originalTyVars) g
|
||||
Right $
|
||||
XObj
|
||||
( Lst
|
||||
( XObj (DefSumtype genericStructTy) Nothing Nothing
|
||||
: XObj (Sym (SymPath [] (tyToC genericStructTy)) Symbol) Nothing Nothing
|
||||
: concretelyTypedCases
|
||||
( XObj (DefSumtype genericStructTy) Nothing Nothing :
|
||||
XObj (Sym (SymPath [] (tyToC genericStructTy)) Symbol) Nothing Nothing :
|
||||
concretelyTypedCases
|
||||
)
|
||||
)
|
||||
(Just dummyInfo)
|
||||
(Just TypeTy)
|
||||
: concat okDeps
|
||||
(Just TypeTy) :
|
||||
concat okDeps
|
||||
Left err -> Left err
|
||||
|
||||
-- Resolves dependencies for sumtype cases.
|
||||
@ -794,12 +794,11 @@ data LifetimeMode
|
||||
deriving (Show)
|
||||
|
||||
-- | To keep track of the deleters when recursively walking the form.
|
||||
data MemState
|
||||
= MemState
|
||||
{ memStateDeleters :: Set.Set Deleter,
|
||||
memStateDeps :: [XObj],
|
||||
memStateLifetimes :: Map.Map String LifetimeMode
|
||||
}
|
||||
data MemState = MemState
|
||||
{ memStateDeleters :: Set.Set Deleter,
|
||||
memStateDeps :: [XObj],
|
||||
memStateLifetimes :: Map.Map String LifetimeMode
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
prettyLifetimeMappings :: Map.Map String LifetimeMode -> String
|
||||
|
@ -165,7 +165,8 @@ templateSetter typeEnv env memberName memberTy =
|
||||
)
|
||||
)
|
||||
( \_ ->
|
||||
if | isManaged typeEnv memberTy -> depsOfPolymorphicFunction typeEnv env [] "delete" (typesDeleterFunctionType memberTy)
|
||||
if
|
||||
| isManaged typeEnv memberTy -> depsOfPolymorphicFunction typeEnv env [] "delete" (typesDeleterFunctionType memberTy)
|
||||
| isFunctionType memberTy -> [defineFunctionTypeAlias memberTy]
|
||||
| otherwise -> []
|
||||
)
|
||||
@ -279,7 +280,7 @@ templateUpdater _ UnitTy =
|
||||
Template
|
||||
(FuncTy [VarTy "p", RefTy (FuncTy [] UnitTy (VarTy "fq")) (VarTy "q")] (VarTy "p") StaticLifetimeTy)
|
||||
(const (toTemplate "$p $NAME($p p, Lambda *updater)")) -- "Lambda" used to be: $(Fn [t] t)
|
||||
-- Execution of the action passed as an argument is handled in Emit.hs.
|
||||
-- Execution of the action passed as an argument is handled in Emit.hs.
|
||||
(const (toTemplate ("$DECL { " ++ templateCodeForCallingLambda "(*updater)" (FuncTy [] UnitTy (VarTy "fq")) [] ++ "; return p;}\n")))
|
||||
( \(FuncTy [_, RefTy t@(FuncTy fArgTys fRetTy _) _] _ _) ->
|
||||
[defineFunctionTypeAlias t, defineFunctionTypeAlias (FuncTy (lambdaEnvTy : fArgTys) fRetTy StaticLifetimeTy)]
|
||||
|
10
src/Eval.hs
10
src/Eval.hs
@ -66,8 +66,8 @@ eval ctx xobj@(XObj o info ty) preference =
|
||||
pure $
|
||||
fromMaybe
|
||||
(evalError ctx ("Can't find symbol '" ++ show n ++ "'") info) -- all else failed, error.
|
||||
-- Certain contexts prefer looking up bindings in the dynamic environment (e.g. defdyanmic) while others
|
||||
-- prefer the static global environment.
|
||||
-- Certain contexts prefer looking up bindings in the dynamic environment (e.g. defdyanmic) while others
|
||||
-- prefer the static global environment.
|
||||
( ( case preference of
|
||||
PreferDynamic -> tryDynamicLookup
|
||||
PreferGlobal -> (tryLookup spath <|> tryDynamicLookup)
|
||||
@ -794,9 +794,9 @@ loadInternal ctx xobj path i reloadMode = do
|
||||
Nothing -> "."
|
||||
carpDir = projectCarpDir proj
|
||||
fullSearchPaths =
|
||||
path
|
||||
: (relativeTo </> path)
|
||||
: map (</> path) (projectCarpSearchPaths proj) -- the path from the file that contains the '(load)', or the current directory if not loading from a file (e.g. the repl)
|
||||
path :
|
||||
(relativeTo </> path) :
|
||||
map (</> path) (projectCarpSearchPaths proj) -- the path from the file that contains the '(load)', or the current directory if not loading from a file (e.g. the repl)
|
||||
++ [carpDir </> "core" </> path] -- user defined search paths
|
||||
++ [libDir </> path]
|
||||
firstM _ [] = pure Nothing
|
||||
|
@ -87,7 +87,8 @@ genConstraints _ root rootSig = fmap sort (gen root)
|
||||
(List.map (forceTy *** forceTy) (pairwise bindings))
|
||||
(pairwise bindings)
|
||||
pure
|
||||
( wholeStatementConstraint : insideBodyConstraints
|
||||
( wholeStatementConstraint :
|
||||
insideBodyConstraints
|
||||
++ bindingsConstraints
|
||||
++ insideBindingsConstraints
|
||||
)
|
||||
@ -106,9 +107,10 @@ genConstraints _ root rootSig = fmap sort (gen root)
|
||||
Just t = xobjTy xobj
|
||||
wholeStatementConstraint = Constraint trueType t ifTrue xobj xobj OrdIfWhole
|
||||
pure
|
||||
( conditionConstraint : sameReturnConstraint
|
||||
: wholeStatementConstraint
|
||||
: insideConditionConstraints
|
||||
( conditionConstraint :
|
||||
sameReturnConstraint :
|
||||
wholeStatementConstraint :
|
||||
insideConditionConstraints
|
||||
++ insideTrueConstraints
|
||||
++ insideFalseConstraints
|
||||
)
|
||||
@ -166,8 +168,9 @@ genConstraints _ root rootSig = fmap sort (gen root)
|
||||
conditionConstraint = Constraint exprType BoolTy expr expectedCond xobj OrdWhileCondition
|
||||
wholeStatementConstraint = Constraint bodyType UnitTy body expectedBody xobj OrdWhileBody
|
||||
pure
|
||||
( conditionConstraint : wholeStatementConstraint
|
||||
: insideConditionConstraints ++ insideBodyConstraints
|
||||
( conditionConstraint :
|
||||
wholeStatementConstraint :
|
||||
insideConditionConstraints ++ insideBodyConstraints
|
||||
)
|
||||
-- Do
|
||||
XObj Do _ _ : expressions ->
|
||||
|
15
src/Info.hs
15
src/Info.hs
@ -18,14 +18,13 @@ import Path (takeFileName)
|
||||
import SymPath
|
||||
|
||||
-- | Information about where the Obj originated from.
|
||||
data Info
|
||||
= Info
|
||||
{ infoLine :: Int,
|
||||
infoColumn :: Int,
|
||||
infoFile :: String,
|
||||
infoDelete :: Set.Set Deleter,
|
||||
infoIdentifier :: Int
|
||||
}
|
||||
data Info = Info
|
||||
{ infoLine :: Int,
|
||||
infoColumn :: Int,
|
||||
infoFile :: String,
|
||||
infoDelete :: Set.Set Deleter,
|
||||
infoIdentifier :: Int
|
||||
}
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
-- TODO: The name 'deleter' for these things are really confusing!
|
||||
|
@ -477,11 +477,11 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
|
||||
createBinderInternal :: XObj -> String -> State Integer [(String, Binder)]
|
||||
createBinderInternal xobj name =
|
||||
if isVarName name
|
||||
then-- A variable that will bind to something:
|
||||
then -- A variable that will bind to something:
|
||||
do
|
||||
freshTy <- genVarTy
|
||||
pure [(name, Binder emptyMeta xobj {xobjTy = Just freshTy})]
|
||||
else-- Tags for the sumtypes won't bind to anything:
|
||||
else -- Tags for the sumtypes won't bind to anything:
|
||||
pure []
|
||||
|
||||
uniquifyWildcardNames :: XObj -> XObj
|
||||
|
@ -56,7 +56,7 @@ registerInInterfaceIfNeeded ctx path@(SymPath _ _) interface@(SymPath [] name) d
|
||||
typeCheck binder = case binder of
|
||||
Binder _ (XObj (Lst [inter@(XObj (Interface interfaceSignature paths) ii it), isym]) i t) ->
|
||||
if checkKinds interfaceSignature definitionSignature
|
||||
then-- N.B. the xobjs aren't important here--we only care about types,
|
||||
then -- N.B. the xobjs aren't important here--we only care about types,
|
||||
-- thus we pass inter to all three xobj positions.
|
||||
|
||||
if isRight $ solve [Constraint interfaceSignature definitionSignature inter inter inter OrdInterfaceImpl]
|
||||
|
71
src/Obj.hs
71
src/Obj.hs
@ -227,12 +227,11 @@ machineReadableInfoFromXObj fppl xobj =
|
||||
Nothing -> ""
|
||||
|
||||
-- | Obj with eXtra information.
|
||||
data XObj
|
||||
= XObj
|
||||
{ xobjObj :: Obj,
|
||||
xobjInfo :: Maybe Info,
|
||||
xobjTy :: Maybe Ty
|
||||
}
|
||||
data XObj = XObj
|
||||
{ xobjObj :: Obj,
|
||||
xobjInfo :: Maybe Info,
|
||||
xobjTy :: Maybe Ty
|
||||
}
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
getBinderDescription :: XObj -> String
|
||||
@ -333,9 +332,10 @@ pretty = visit 0
|
||||
MultiSym originalName paths -> originalName ++ "{" ++ joinWithComma (map show paths) ++ "}"
|
||||
InterfaceSym name -> name -- ++ "§"
|
||||
Bol b -> if b then "true" else "false"
|
||||
Defn maybeCaptures -> "defn" ++ case maybeCaptures of
|
||||
Just captures -> " <" ++ prettyCaptures captures ++ ">"
|
||||
Nothing -> ""
|
||||
Defn maybeCaptures ->
|
||||
"defn" ++ case maybeCaptures of
|
||||
Just captures -> " <" ++ prettyCaptures captures ++ ">"
|
||||
Nothing -> ""
|
||||
Def -> "def"
|
||||
Fn _ captures -> "fn" ++ " <" ++ prettyCaptures captures ++ ">"
|
||||
Closure elt _ -> "closure<" ++ pretty elt ++ ">"
|
||||
@ -582,15 +582,14 @@ register name t =
|
||||
data EnvMode = ExternalEnv | InternalEnv | RecursionEnv deriving (Show, Eq)
|
||||
|
||||
-- | Environment
|
||||
data Env
|
||||
= Env
|
||||
{ envBindings :: Map.Map String Binder,
|
||||
envParent :: Maybe Env,
|
||||
envModuleName :: Maybe String,
|
||||
envUseModules :: [SymPath],
|
||||
envMode :: EnvMode,
|
||||
envFunctionNestingLevel :: Int -- Normal defn:s have 0, lambdas get +1 for each level of nesting
|
||||
}
|
||||
data Env = Env
|
||||
{ envBindings :: Map.Map String Binder,
|
||||
envParent :: Maybe Env,
|
||||
envModuleName :: Maybe String,
|
||||
envUseModules :: [SymPath],
|
||||
envMode :: EnvMode,
|
||||
envFunctionNestingLevel :: Int -- Normal defn:s have 0, lambdas get +1 for each level of nesting
|
||||
}
|
||||
deriving (Show, Eq)
|
||||
|
||||
newtype ClosureContext = CCtx Context
|
||||
@ -772,13 +771,12 @@ polymorphicSuffix signature actualType =
|
||||
type VisitedTypes = [Ty]
|
||||
|
||||
-- | Templates are like macros, but defined inside the compiler and with access to the types they are instantiated with
|
||||
data Template
|
||||
= Template
|
||||
{ templateSignature :: Ty,
|
||||
templateDeclaration :: Ty -> [Token], -- Will this parameterization ever be useful?
|
||||
templateDefinition :: Ty -> [Token],
|
||||
templateDependencies :: Ty -> [XObj]
|
||||
}
|
||||
data Template = Template
|
||||
{ templateSignature :: Ty,
|
||||
templateDeclaration :: Ty -> [Token], -- Will this parameterization ever be useful?
|
||||
templateDefinition :: Ty -> [Token],
|
||||
templateDependencies :: Ty -> [XObj]
|
||||
}
|
||||
|
||||
instance Show Template where
|
||||
show _ = "Template"
|
||||
@ -795,7 +793,7 @@ data Token
|
||||
= TokTy Ty TokTyMode -- Some kind of type, will be looked up if it's a type variable.
|
||||
| TokC String -- Plain C code.
|
||||
| TokDecl -- Will emit the declaration (i.e. "foo(int x)"), this is useful
|
||||
-- for avoiding repetition in the definition part of the template.
|
||||
-- for avoiding repetition in the definition part of the template.
|
||||
| TokName -- Will emit the name of the instantiated function/variable.
|
||||
deriving (Eq, Ord)
|
||||
|
||||
@ -853,17 +851,16 @@ forceTy xobj = fromMaybe (error ("No type in " ++ show xobj)) (xobjTy xobj)
|
||||
data ExecutionMode = Repl | Build | BuildAndRun | Install String | Check deriving (Show, Eq)
|
||||
|
||||
-- | Information needed by the REPL
|
||||
data Context
|
||||
= Context
|
||||
{ contextGlobalEnv :: Env,
|
||||
contextInternalEnv :: Maybe Env,
|
||||
contextTypeEnv :: TypeEnv,
|
||||
contextPath :: [String],
|
||||
contextProj :: Project,
|
||||
contextLastInput :: String,
|
||||
contextExecMode :: ExecutionMode,
|
||||
contextHistory :: ![XObj]
|
||||
}
|
||||
data Context = Context
|
||||
{ contextGlobalEnv :: Env,
|
||||
contextInternalEnv :: Maybe Env,
|
||||
contextTypeEnv :: TypeEnv,
|
||||
contextPath :: [String],
|
||||
contextProj :: Project,
|
||||
contextLastInput :: String,
|
||||
contextExecMode :: ExecutionMode,
|
||||
contextHistory :: ![XObj]
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
popModulePath :: Context -> Context
|
||||
|
@ -372,7 +372,7 @@ symbol = do
|
||||
i <- createInfo
|
||||
segments <- Parsec.sepBy1 symbolSegment period
|
||||
if length segments > 1
|
||||
then-- if it’s qualified, it can’t be a special form
|
||||
then -- if it’s qualified, it can’t be a special form
|
||||
|
||||
pure
|
||||
( XObj
|
||||
@ -532,8 +532,8 @@ dictionary = do
|
||||
_ <- Parsec.char '}'
|
||||
incColumn 1
|
||||
let objs' = if even (length objs) then objs else init objs -- Drop last if uneven nr of forms.
|
||||
-- TODO! Signal error here!
|
||||
--pure (XObj (Dict (Map.fromList (pairwise objs'))) i Nothing)
|
||||
-- TODO! Signal error here!
|
||||
--pure (XObj (Dict (Map.fromList (pairwise objs'))) i Nothing)
|
||||
pairInit = XObj (Sym (SymPath ["Pair"] "init") (LookupGlobal CarpLand AFunction)) i Nothing
|
||||
pairs = map (\(k, v) -> XObj (Lst [pairInit, k, v]) i Nothing) (pairwise objs')
|
||||
arrayLiteral = XObj (Arr pairs) i Nothing
|
||||
|
@ -437,9 +437,9 @@ primitiveMembers _ ctx [target] = do
|
||||
_
|
||||
( XObj
|
||||
( Lst
|
||||
( XObj (DefSumtype _) Nothing Nothing :
|
||||
XObj (Sym (SymPath _ _) Symbol) Nothing Nothing :
|
||||
sumtypeCases
|
||||
( XObj (DefSumtype _) Nothing Nothing
|
||||
: XObj (Sym (SymPath _ _) Symbol) Nothing Nothing
|
||||
: sumtypeCases
|
||||
)
|
||||
)
|
||||
_
|
||||
@ -485,23 +485,29 @@ primitiveMetaSet _ ctx [target@(XObj (Sym (SymPath prefixes name) _) _ _), XObj
|
||||
lookupAndUpdate :: Maybe Context
|
||||
lookupAndUpdate =
|
||||
( (lookupInEnv dynamicPath global)
|
||||
>>= \(_, binder) -> (pure (Meta.updateBinderMeta binder key value))
|
||||
>>= \b -> (pure (envInsertAt global dynamicPath b))
|
||||
>>= \env -> pure (ctx {contextGlobalEnv = env})
|
||||
>>= \(_, binder) ->
|
||||
(pure (Meta.updateBinderMeta binder key value))
|
||||
>>= \b ->
|
||||
(pure (envInsertAt global dynamicPath b))
|
||||
>>= \env -> pure (ctx {contextGlobalEnv = env})
|
||||
)
|
||||
<|> ( (lookupInEnv fullPath global)
|
||||
>>= \(_, binder) -> (pure (Meta.updateBinderMeta binder key value))
|
||||
>>= \b -> (pure (envInsertAt global fullPath b))
|
||||
>>= \env -> pure (ctx {contextGlobalEnv = env})
|
||||
>>= \(_, binder) ->
|
||||
(pure (Meta.updateBinderMeta binder key value))
|
||||
>>= \b ->
|
||||
(pure (envInsertAt global fullPath b))
|
||||
>>= \env -> pure (ctx {contextGlobalEnv = env})
|
||||
)
|
||||
-- This is a global name but it doesn't exist in the global env
|
||||
-- Before creating a new binder, check that it doesn't denote an existing type or interface.
|
||||
<|> ( if (null modules)
|
||||
then
|
||||
( (lookupInEnv fullPath types)
|
||||
>>= \(_, binder) -> (pure (Meta.updateBinderMeta binder key value))
|
||||
>>= \b -> (pure (envInsertAt types fullPath b))
|
||||
>>= \env -> pure (ctx {contextTypeEnv = (TypeEnv env)})
|
||||
>>= \(_, binder) ->
|
||||
(pure (Meta.updateBinderMeta binder key value))
|
||||
>>= \b ->
|
||||
(pure (envInsertAt types fullPath b))
|
||||
>>= \env -> pure (ctx {contextTypeEnv = (TypeEnv env)})
|
||||
)
|
||||
else Nothing
|
||||
)
|
||||
@ -691,9 +697,9 @@ primitiveDeftype xobj ctx (name : rest) =
|
||||
-- NOTE: The type binding is needed to emit the type definition and all the member functions of the type.
|
||||
XObj
|
||||
( Lst
|
||||
( XObj (typeConstructor structTy) Nothing Nothing
|
||||
: XObj (Sym (SymPath pathStrings tyName) Symbol) Nothing Nothing
|
||||
: rest
|
||||
( XObj (typeConstructor structTy) Nothing Nothing :
|
||||
XObj (Sym (SymPath pathStrings tyName) Symbol) Nothing Nothing :
|
||||
rest
|
||||
)
|
||||
)
|
||||
i
|
||||
|
@ -12,40 +12,39 @@ instance Show Target where
|
||||
show (Target x) = x
|
||||
|
||||
-- | Project (represents a lot of useful information for working at the REPL and building executables)
|
||||
data Project
|
||||
= Project
|
||||
{ projectTitle :: String,
|
||||
projectIncludes :: [Includer],
|
||||
projectCFlags :: [String],
|
||||
projectLibFlags :: [String],
|
||||
projectPkgConfigFlags :: [String],
|
||||
projectFiles :: [(FilePath, ReloadMode)],
|
||||
projectAlreadyLoaded :: [FilePath],
|
||||
projectEchoC :: Bool,
|
||||
projectLibDir :: FilePath,
|
||||
projectCarpDir :: FilePath,
|
||||
projectOutDir :: FilePath,
|
||||
projectDocsDir :: FilePath,
|
||||
projectDocsLogo :: FilePath,
|
||||
projectDocsPrelude :: String,
|
||||
projectDocsURL :: String,
|
||||
projectDocsGenerateIndex :: Bool,
|
||||
projectDocsStyling :: String,
|
||||
projectPrompt :: String,
|
||||
projectCarpSearchPaths :: [FilePath],
|
||||
projectPrintTypedAST :: Bool,
|
||||
projectCompiler :: String,
|
||||
projectTarget :: Target,
|
||||
projectCore :: Bool,
|
||||
projectEchoCompilationCommand :: Bool,
|
||||
projectCanExecute :: Bool,
|
||||
projectFilePathPrintLength :: FilePathPrintLength,
|
||||
projectGenerateOnly :: Bool,
|
||||
projectBalanceHints :: Bool,
|
||||
projectForceReload :: Bool, -- Setting this to true will make the `load-once` command work just like `load`.
|
||||
projectCModules :: [FilePath],
|
||||
projectLoadStack :: [FilePath]
|
||||
}
|
||||
data Project = Project
|
||||
{ projectTitle :: String,
|
||||
projectIncludes :: [Includer],
|
||||
projectCFlags :: [String],
|
||||
projectLibFlags :: [String],
|
||||
projectPkgConfigFlags :: [String],
|
||||
projectFiles :: [(FilePath, ReloadMode)],
|
||||
projectAlreadyLoaded :: [FilePath],
|
||||
projectEchoC :: Bool,
|
||||
projectLibDir :: FilePath,
|
||||
projectCarpDir :: FilePath,
|
||||
projectOutDir :: FilePath,
|
||||
projectDocsDir :: FilePath,
|
||||
projectDocsLogo :: FilePath,
|
||||
projectDocsPrelude :: String,
|
||||
projectDocsURL :: String,
|
||||
projectDocsGenerateIndex :: Bool,
|
||||
projectDocsStyling :: String,
|
||||
projectPrompt :: String,
|
||||
projectCarpSearchPaths :: [FilePath],
|
||||
projectPrintTypedAST :: Bool,
|
||||
projectCompiler :: String,
|
||||
projectTarget :: Target,
|
||||
projectCore :: Bool,
|
||||
projectEchoCompilationCommand :: Bool,
|
||||
projectCanExecute :: Bool,
|
||||
projectFilePathPrintLength :: FilePathPrintLength,
|
||||
projectGenerateOnly :: Bool,
|
||||
projectBalanceHints :: Bool,
|
||||
projectForceReload :: Bool, -- Setting this to true will make the `load-once` command work just like `load`.
|
||||
projectCModules :: [FilePath],
|
||||
projectLoadStack :: [FilePath]
|
||||
}
|
||||
|
||||
projectFlags :: Project -> String
|
||||
projectFlags proj = joinWithSpace (projectCFlags proj ++ projectLibFlags proj)
|
||||
|
@ -14,8 +14,8 @@ import Obj
|
||||
import Path
|
||||
import Project
|
||||
import Text.Blaze.Html.Renderer.Pretty (renderHtml)
|
||||
import qualified Text.Blaze.Html5 as H
|
||||
import Text.Blaze.Html5 ((!))
|
||||
import qualified Text.Blaze.Html5 as H
|
||||
import qualified Text.Blaze.Html5.Attributes as A
|
||||
import Types
|
||||
|
||||
@ -62,21 +62,22 @@ projectIndexPage ctx moduleNames =
|
||||
css = projectDocsStyling ctx
|
||||
htmlHeader = H.toHtml $ projectTitle ctx
|
||||
htmlDoc = commonmarkToHtml [optSafe] $ Text.pack $ projectDocsPrelude ctx
|
||||
html = renderHtml $ H.docTypeHtml $
|
||||
do
|
||||
headOfPage css
|
||||
H.body
|
||||
$ H.div ! A.class_ "content"
|
||||
$ H.a ! A.href (H.stringValue url)
|
||||
$ do
|
||||
H.div ! A.class_ "logo" $
|
||||
do
|
||||
H.img ! A.src (H.stringValue logo) ! A.alt "Logo"
|
||||
moduleIndex moduleNames
|
||||
H.div $
|
||||
do
|
||||
H.h1 htmlHeader
|
||||
H.preEscapedToHtml htmlDoc
|
||||
html = renderHtml $
|
||||
H.docTypeHtml $
|
||||
do
|
||||
headOfPage css
|
||||
H.body $
|
||||
H.div ! A.class_ "content" $
|
||||
H.a ! A.href (H.stringValue url) $
|
||||
do
|
||||
H.div ! A.class_ "logo" $
|
||||
do
|
||||
H.img ! A.src (H.stringValue logo) ! A.alt "Logo"
|
||||
moduleIndex moduleNames
|
||||
H.div $
|
||||
do
|
||||
H.h1 htmlHeader
|
||||
H.preEscapedToHtml htmlDoc
|
||||
in html
|
||||
|
||||
headOfPage :: String -> H.Html
|
||||
@ -114,19 +115,19 @@ envBinderToHtml envBinder ctx moduleName moduleNames =
|
||||
in H.docTypeHtml $
|
||||
do
|
||||
headOfPage css
|
||||
H.body
|
||||
$ H.div ! A.class_ "content"
|
||||
$ do
|
||||
H.div ! A.class_ "logo" $
|
||||
do
|
||||
H.a ! A.href (H.stringValue url) $
|
||||
H.img ! A.src (H.stringValue logo)
|
||||
--span_ "CARP DOCS FOR"
|
||||
H.div ! A.class_ "title" $ H.toHtml title
|
||||
moduleIndex moduleNames
|
||||
H.h1 (H.toHtml moduleName)
|
||||
H.div ! A.class_ "module-description" $ H.preEscapedToHtml moduleDescriptionHtml
|
||||
mapM_ (binderToHtml . snd) (Prelude.filter shouldEmitDocsForBinder (Map.toList (envBindings env)))
|
||||
H.body $
|
||||
H.div ! A.class_ "content" $
|
||||
do
|
||||
H.div ! A.class_ "logo" $
|
||||
do
|
||||
H.a ! A.href (H.stringValue url) $
|
||||
H.img ! A.src (H.stringValue logo)
|
||||
--span_ "CARP DOCS FOR"
|
||||
H.div ! A.class_ "title" $ H.toHtml title
|
||||
moduleIndex moduleNames
|
||||
H.h1 (H.toHtml moduleName)
|
||||
H.div ! A.class_ "module-description" $ H.preEscapedToHtml moduleDescriptionHtml
|
||||
mapM_ (binderToHtml . snd) (Prelude.filter shouldEmitDocsForBinder (Map.toList (envBindings env)))
|
||||
|
||||
shouldEmitDocsForBinder :: (String, Binder) -> Bool
|
||||
shouldEmitDocsForBinder (_, Binder meta _) =
|
||||
@ -134,9 +135,9 @@ shouldEmitDocsForBinder (_, Binder meta _) =
|
||||
|
||||
moduleIndex :: [String] -> H.Html
|
||||
moduleIndex moduleNames =
|
||||
H.div ! A.class_ "index"
|
||||
$ H.ul
|
||||
$ mapM_ moduleLink moduleNames
|
||||
H.div ! A.class_ "index" $
|
||||
H.ul $
|
||||
mapM_ moduleLink moduleNames
|
||||
|
||||
moduleLink :: String -> H.Html
|
||||
moduleLink name =
|
||||
@ -157,13 +158,14 @@ binderToHtml (Binder meta xobj) =
|
||||
htmlDoc = commonmarkToHtml [optSafe] $ Text.pack docString
|
||||
in H.div ! A.class_ "binder" $
|
||||
do
|
||||
H.a ! A.class_ "anchor" ! A.href (H.stringValue ("#" ++ name))
|
||||
$ H.h3 ! A.id (H.stringValue name)
|
||||
$ H.toHtml name
|
||||
H.a ! A.class_ "anchor" ! A.href (H.stringValue ("#" ++ name)) $
|
||||
H.h3 ! A.id (H.stringValue name) $
|
||||
H.toHtml name
|
||||
H.div ! A.class_ "description" $ H.toHtml description
|
||||
H.p ! A.class_ "sig" $ H.toHtml typeSignature
|
||||
case maybeNameAndArgs of
|
||||
Just nameAndArgs -> H.pre ! A.class_ "args" $ H.toHtml nameAndArgs
|
||||
Nothing -> H.span $ H.toHtml ("" :: String)
|
||||
H.p ! A.class_ "doc" $ H.preEscapedToHtml htmlDoc
|
||||
|
||||
--p_ (toHtml (description))
|
||||
|
@ -68,19 +68,20 @@ depthOfType typeEnv visited selfName theType =
|
||||
visitType (RefTy r lt) = max (visitType r) (visitType lt)
|
||||
visitType _ = 1
|
||||
depthOfStructType :: String -> [Ty] -> Int
|
||||
depthOfStructType name varTys = 1
|
||||
+ case name of
|
||||
"Array" -> depthOfVarTys
|
||||
_
|
||||
| name == selfName -> 1
|
||||
| otherwise ->
|
||||
case lookupInEnv (SymPath [] name) (getTypeEnv typeEnv) of
|
||||
Just (_, Binder _ typedef) -> depthOfDeftype typeEnv (Set.insert theType visited) typedef varTys
|
||||
Nothing ->
|
||||
--trace ("Unknown type: " ++ name) $
|
||||
depthOfVarTys -- The problem here is that generic types don't generate
|
||||
-- their definition in time so we get nothing for those.
|
||||
-- Instead, let's try the type vars.
|
||||
depthOfStructType name varTys =
|
||||
1
|
||||
+ case name of
|
||||
"Array" -> depthOfVarTys
|
||||
_
|
||||
| name == selfName -> 1
|
||||
| otherwise ->
|
||||
case lookupInEnv (SymPath [] name) (getTypeEnv typeEnv) of
|
||||
Just (_, Binder _ typedef) -> depthOfDeftype typeEnv (Set.insert theType visited) typedef varTys
|
||||
Nothing ->
|
||||
--trace ("Unknown type: " ++ name) $
|
||||
depthOfVarTys -- The problem here is that generic types don't generate
|
||||
-- their definition in time so we get nothing for those.
|
||||
-- Instead, let's try the type vars.
|
||||
where
|
||||
depthOfVarTys =
|
||||
case fmap (depthOfType typeEnv visited name) varTys of
|
||||
|
@ -5,11 +5,10 @@ import TypeError
|
||||
import Types
|
||||
import Validate
|
||||
|
||||
data SumtypeCase
|
||||
= SumtypeCase
|
||||
{ caseName :: String,
|
||||
caseTys :: [Ty]
|
||||
}
|
||||
data SumtypeCase = SumtypeCase
|
||||
{ caseName :: String,
|
||||
caseTys :: [Ty]
|
||||
}
|
||||
deriving (Show, Eq)
|
||||
|
||||
toCases :: TypeEnv -> [Ty] -> [XObj] -> Either TypeError [SumtypeCase]
|
||||
|
@ -2,8 +2,8 @@ module ToTemplate where
|
||||
|
||||
import Obj
|
||||
import Parsing
|
||||
import qualified Text.Parsec as Parsec
|
||||
import Text.Parsec ((<|>))
|
||||
import qualified Text.Parsec as Parsec
|
||||
import Util
|
||||
|
||||
-- | High-level helper function for creating templates from strings of C code.
|
||||
|
@ -86,11 +86,10 @@ typeEqIgnoreLifetimes (StructTy a tyVarsA) (StructTy b tyVarsB) =
|
||||
&& all (== True) (zipWith typeEqIgnoreLifetimes tyVarsA tyVarsB)
|
||||
typeEqIgnoreLifetimes a b = a == b
|
||||
|
||||
data SumTyCase
|
||||
= SumTyCase
|
||||
{ caseName :: String,
|
||||
caseMembers :: [(String, Ty)]
|
||||
}
|
||||
data SumTyCase = SumTyCase
|
||||
{ caseName :: String,
|
||||
caseMembers :: [(String, Ty)]
|
||||
}
|
||||
deriving (Show, Ord, Eq)
|
||||
|
||||
fnOrLambda :: String
|
||||
|
@ -1,7 +1,7 @@
|
||||
module Validate where
|
||||
|
||||
import Data.Function (on)
|
||||
import Data.List ((\\), nubBy)
|
||||
import Data.List (nubBy, (\\))
|
||||
import Lookup
|
||||
import Obj
|
||||
import TypeError
|
||||
|
Loading…
Reference in New Issue
Block a user