mirror of
https://github.com/anoma/juvix.git
synced 2024-11-28 01:23:11 +03:00
Update ci to use ormolu 0.5.3.0 and reformat project (#2313)
Updates ormolu to 0.5.3.0 and formats the project
This commit is contained in:
parent
93a91a70a7
commit
491f7f7508
2
.github/workflows/ci.yml
vendored
2
.github/workflows/ci.yml
vendored
@ -43,7 +43,7 @@ jobs:
|
||||
- uses: actions/checkout@v3
|
||||
- uses: mrkkrp/ormolu-action@v11
|
||||
with:
|
||||
version: 0.5.2.0
|
||||
version: 0.5.3.0
|
||||
extra-args: >-
|
||||
--ghc-opt -XDerivingStrategies --ghc-opt -XImportQualifiedPost
|
||||
--ghc-opt -XMultiParamTypeClasses --ghc-opt -XStandaloneDeriving
|
||||
|
@ -132,7 +132,7 @@ someBaseToAbs' f = do
|
||||
r <- askInvokeDir
|
||||
return (someBaseToAbs r f)
|
||||
|
||||
filePathToAbs :: Members '[Embed IO, App] r => Prepath FileOrDir -> Sem r (Either (Path Abs File) (Path Abs Dir))
|
||||
filePathToAbs :: (Members '[Embed IO, App] r) => Prepath FileOrDir -> Sem r (Either (Path Abs File) (Path Abs Dir))
|
||||
filePathToAbs fp = do
|
||||
invokeDir <- askInvokeDir
|
||||
embed (fromPreFileOrDir invokeDir fp)
|
||||
|
@ -2,7 +2,7 @@ module Commands.Clean where
|
||||
|
||||
import Commands.Base
|
||||
|
||||
runCommand :: Members '[Files, App] r => Sem r ()
|
||||
runCommand :: (Members '[Files, App] r) => Sem r ()
|
||||
runCommand = do
|
||||
buildDir <- askBuildDir
|
||||
whenM (directoryExists' buildDir) (removeDirectoryRecursive' buildDir)
|
||||
|
@ -18,7 +18,7 @@ data PipelineArg = PipelineArg
|
||||
_pipelineArgInfoTable :: Core.InfoTable
|
||||
}
|
||||
|
||||
getEntry :: Members '[Embed IO, App] r => PipelineArg -> Sem r EntryPoint
|
||||
getEntry :: (Members '[Embed IO, App] r) => PipelineArg -> Sem r EntryPoint
|
||||
getEntry PipelineArg {..} = do
|
||||
ep <- getEntryPoint (AppPath (preFileFromAbs _pipelineArgFile) True)
|
||||
return $
|
||||
|
@ -10,7 +10,7 @@ import Juvix.Compiler.Core.Transformation qualified as Core
|
||||
import Juvix.Compiler.Core.Transformation.DisambiguateNames (disambiguateNames)
|
||||
import Juvix.Compiler.Core.Translation
|
||||
|
||||
runCommand :: forall r. Members '[Embed IO, App] r => CoreFromConcreteOptions -> Sem r ()
|
||||
runCommand :: forall r. (Members '[Embed IO, App] r) => CoreFromConcreteOptions -> Sem r ()
|
||||
runCommand localOpts = do
|
||||
gopts <- askGlobalOptions
|
||||
tab <- (^. coreResultTable) <$> runPipeline (localOpts ^. coreFromConcreteInputFile) upToCore
|
||||
|
@ -4,7 +4,7 @@ import Commands.Base
|
||||
import Commands.Dev.Highlight.Options
|
||||
import Juvix.Compiler.Concrete.Data.Highlight qualified as Highlight
|
||||
|
||||
runCommand :: Members '[Embed IO, App] r => HighlightOptions -> Sem r ()
|
||||
runCommand :: (Members '[Embed IO, App] r) => HighlightOptions -> Sem r ()
|
||||
runCommand HighlightOptions {..} = do
|
||||
entry <- getEntryPoint _highlightInputFile
|
||||
inputFile <- fromAppPathFile _highlightInputFile
|
||||
|
@ -7,7 +7,7 @@ import Commands.Dev.Internal.Pretty qualified as Pretty
|
||||
import Commands.Dev.Internal.Reachability qualified as Reachability
|
||||
import Commands.Dev.Internal.Typecheck qualified as Typecheck
|
||||
|
||||
runCommand :: Members '[Embed IO, App] r => InternalCommand -> Sem r ()
|
||||
runCommand :: (Members '[Embed IO, App] r) => InternalCommand -> Sem r ()
|
||||
runCommand = \case
|
||||
Pretty opts -> Pretty.runCommand opts
|
||||
Arity opts -> Arity.runCommand opts
|
||||
|
@ -7,7 +7,7 @@ import Juvix.Compiler.Internal.Pretty qualified as Internal
|
||||
import Juvix.Compiler.Internal.Translation.FromConcrete qualified as Internal
|
||||
import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.Termination qualified as Termination
|
||||
|
||||
runCommand :: Members '[Embed IO, App] r => CallsOptions -> Sem r ()
|
||||
runCommand :: (Members '[Embed IO, App] r) => CallsOptions -> Sem r ()
|
||||
runCommand localOpts@CallsOptions {..} = do
|
||||
globalOpts <- askGlobalOptions
|
||||
results <- runPipeline _callsInputFile upToInternal
|
||||
|
@ -129,10 +129,10 @@ documentedCheck ::
|
||||
([Text] -> Sem r ()) -> DocumentedWarning -> Sem r ()
|
||||
documentedCheck check w = check (renderDocumentedWarning w)
|
||||
|
||||
findClangPath :: Members DoctorEff r => Sem r (Maybe ClangPath)
|
||||
findClangPath :: (Members DoctorEff r) => Sem r (Maybe ClangPath)
|
||||
findClangPath = findClang
|
||||
|
||||
checkClang :: forall r. Members DoctorEff r => Bool -> Sem r ()
|
||||
checkClang :: forall r. (Members DoctorEff r) => Bool -> Sem r ()
|
||||
checkClang printVerbose = do
|
||||
heading "Checking for clang..."
|
||||
clangPath <- findClangPath
|
||||
|
@ -75,7 +75,7 @@ prepareRuntime buildDir o = do
|
||||
ensureDir (includeDir <//> parent filePath)
|
||||
BS.writeFile (toFilePath (includeDir <//> filePath)) contents
|
||||
|
||||
outputFile :: forall r. Member App r => CompileOptions -> Path Abs File -> Sem r (Path Abs File)
|
||||
outputFile :: forall r. (Member App r) => CompileOptions -> Path Abs File -> Sem r (Path Abs File)
|
||||
outputFile opts inputFile =
|
||||
maybe defaultOutputFile fromAppPathFile (opts ^? compileOutputFile . _Just)
|
||||
where
|
||||
@ -208,10 +208,10 @@ wasiArgs buildDir o outfile inputFile sysrootPath =
|
||||
| otherwise -> []
|
||||
)
|
||||
|
||||
findClangOnPath :: Member (Embed IO) r => Sem r (Maybe (Path Abs File))
|
||||
findClangOnPath :: (Member (Embed IO) r) => Sem r (Maybe (Path Abs File))
|
||||
findClangOnPath = findExecutable $(mkRelFile "clang")
|
||||
|
||||
findClangUsingEnvVar :: forall r. Member (Embed IO) r => Sem r (Maybe (Path Abs File))
|
||||
findClangUsingEnvVar :: forall r. (Member (Embed IO) r) => Sem r (Maybe (Path Abs File))
|
||||
findClangUsingEnvVar = do
|
||||
p <- clangBinPath
|
||||
join <$> mapM checkExecutable p
|
||||
@ -237,7 +237,7 @@ extractClangPath = \case
|
||||
ClangEnvVarPath p -> p
|
||||
|
||||
--- Try searching clang JUVIX_LLVM_DIST_PATH. Otherwise use the PATH
|
||||
findClang :: Member (Embed IO) r => Sem r (Maybe ClangPath)
|
||||
findClang :: (Member (Embed IO) r) => Sem r (Maybe ClangPath)
|
||||
findClang = do
|
||||
envVarPath <- findClangUsingEnvVar
|
||||
case envVarPath of
|
||||
|
@ -25,7 +25,7 @@ isTargetProject = \case
|
||||
TargetProject {} -> True
|
||||
_ -> False
|
||||
|
||||
targetFromOptions :: Members '[Embed IO, App] r => FormatOptions -> Sem r FormatTarget
|
||||
targetFromOptions :: (Members '[Embed IO, App] r) => FormatOptions -> Sem r FormatTarget
|
||||
targetFromOptions opts = do
|
||||
globalOpts <- askGlobalOptions
|
||||
let isStdin = globalOpts ^. globalStdin
|
||||
@ -46,7 +46,7 @@ targetFromOptions opts = do
|
||||
"Use the --help option to display more usage information."
|
||||
]
|
||||
|
||||
runCommand :: forall r. Members '[Embed IO, App, Resource, Files] r => FormatOptions -> Sem r ()
|
||||
runCommand :: forall r. (Members '[Embed IO, App, Resource, Files] r) => FormatOptions -> Sem r ()
|
||||
runCommand opts = do
|
||||
target <- targetFromOptions opts
|
||||
runOutputSem (renderFormattedOutput target opts) $ runScopeFileApp $ do
|
||||
@ -81,7 +81,7 @@ renderModeFromOptions target opts formattedInfo
|
||||
| formattedInfo ^. formattedFileInfoContentsModified = res
|
||||
| otherwise = NoEdit Silent
|
||||
|
||||
renderFormattedOutput :: forall r. Members '[Embed IO, App, Resource, Files] r => FormatTarget -> FormatOptions -> FormattedFileInfo -> Sem r ()
|
||||
renderFormattedOutput :: forall r. (Members '[Embed IO, App, Resource, Files] r) => FormatTarget -> FormatOptions -> FormattedFileInfo -> Sem r ()
|
||||
renderFormattedOutput target opts fInfo = do
|
||||
let renderMode = renderModeFromOptions target opts fInfo
|
||||
outputResult renderMode
|
||||
@ -97,7 +97,7 @@ renderFormattedOutput target opts fInfo = do
|
||||
InputPath p -> say (pack (toFilePath p))
|
||||
Silent -> return ()
|
||||
|
||||
runScopeFileApp :: Member App r => Sem (ScopeEff ': r) a -> Sem r a
|
||||
runScopeFileApp :: (Member App r) => Sem (ScopeEff ': r) a -> Sem r a
|
||||
runScopeFileApp = interpret $ \case
|
||||
ScopeFile p -> do
|
||||
let appFile =
|
||||
|
@ -39,7 +39,7 @@ checkNotInProject =
|
||||
say "You are already in a Juvix project"
|
||||
embed exitFailure
|
||||
|
||||
getPackage :: forall r. Members '[Embed IO] r => Sem r Package
|
||||
getPackage :: forall r. (Members '[Embed IO] r) => Sem r Package
|
||||
getPackage = do
|
||||
tproj <- getProjName
|
||||
say "Write the version of your project [leave empty for 0.0.0]"
|
||||
|
@ -100,7 +100,7 @@ replError msg =
|
||||
noFileLoadedErr :: Repl a
|
||||
noFileLoadedErr = replError (mkAnsiText @Text "No file loaded. Load a file using the `:load FILE` command.")
|
||||
|
||||
welcomeMsg :: MonadIO m => m ()
|
||||
welcomeMsg :: (MonadIO m) => m ()
|
||||
welcomeMsg = liftIO (putStrLn [i|Juvix REPL version #{versionTag}: https://juvix.org. Run :help for help|])
|
||||
|
||||
multilineCmd :: String
|
||||
@ -233,16 +233,16 @@ dev input = do
|
||||
scoperStateCmd :: String
|
||||
scoperStateCmd = "scoperState"
|
||||
|
||||
ppConcrete :: Concrete.PrettyPrint a => a -> Repl AnsiText
|
||||
ppConcrete :: (Concrete.PrettyPrint a) => a -> Repl AnsiText
|
||||
ppConcrete a = do
|
||||
gopts <- State.gets (^. replStateGlobalOptions)
|
||||
let popts :: GenericOptions = project' gopts
|
||||
return (Concrete.ppOut popts a)
|
||||
|
||||
printConcrete :: Concrete.PrettyPrint a => a -> Repl ()
|
||||
printConcrete :: (Concrete.PrettyPrint a) => a -> Repl ()
|
||||
printConcrete = ppConcrete >=> renderOut
|
||||
|
||||
printConcreteLn :: Concrete.PrettyPrint a => a -> Repl ()
|
||||
printConcreteLn :: (Concrete.PrettyPrint a) => a -> Repl ()
|
||||
printConcreteLn = ppConcrete >=> renderOutLn
|
||||
|
||||
replParseIdentifiers :: String -> Repl (NonEmpty Concrete.ScopedIden)
|
||||
@ -347,7 +347,7 @@ printDefinition = replParseIdentifiers >=> printIdentifiers
|
||||
KNameFixity -> impossible
|
||||
KNameAlias -> impossible
|
||||
where
|
||||
printLocation :: HasLoc s => s -> Repl ()
|
||||
printLocation :: (HasLoc s) => s -> Repl ()
|
||||
printLocation def = do
|
||||
s' <- ppConcrete s
|
||||
let txt :: Text = " is " <> prettyText (nameKindWithArticle (getNameKind s)) <> " defined at " <> prettyText (getLoc def)
|
||||
@ -475,7 +475,7 @@ printRoot _ = do
|
||||
r <- State.gets (^. replStateRoots . rootsRootDir)
|
||||
liftIO $ putStrLn (pack (toFilePath r))
|
||||
|
||||
runCommand :: Members '[Embed IO, App] r => ReplOptions -> Sem r ()
|
||||
runCommand :: (Members '[Embed IO, App] r) => ReplOptions -> Sem r ()
|
||||
runCommand opts = do
|
||||
roots <- askRoots
|
||||
let replAction :: ReplS ()
|
||||
@ -596,7 +596,7 @@ printErrorS e = do
|
||||
|
||||
runTransformations ::
|
||||
forall r.
|
||||
Members '[State Artifacts, Error JuvixError, Reader EntryPoint] r =>
|
||||
(Members '[State Artifacts, Error JuvixError, Reader EntryPoint] r) =>
|
||||
Bool ->
|
||||
[Core.TransformationId] ->
|
||||
Core.Node ->
|
||||
|
@ -3,7 +3,7 @@ module Commands.Typecheck where
|
||||
import Commands.Base
|
||||
import Commands.Typecheck.Options
|
||||
|
||||
runCommand :: Members '[Embed IO, App] r => TypecheckOptions -> Sem r ()
|
||||
runCommand :: (Members '[Embed IO, App] r) => TypecheckOptions -> Sem r ()
|
||||
runCommand localOpts = do
|
||||
void (runPipeline (localOpts ^. typecheckInputFile) upToCoreTypecheck)
|
||||
say "Well done! It type checks"
|
||||
|
@ -14,8 +14,8 @@ import Juvix.Compiler.Pipeline.EntryPoint
|
||||
|
||||
-- | Perform transformations on JuvixAsm necessary before the translation to
|
||||
-- JuvixReg
|
||||
toReg' :: Members '[Error AsmError, Reader Options] r => InfoTable -> Sem r InfoTable
|
||||
toReg' :: (Members '[Error AsmError, Reader Options] r) => InfoTable -> Sem r InfoTable
|
||||
toReg' = validate >=> computeStackUsage >=> computePrealloc
|
||||
|
||||
toReg :: Members '[Error JuvixError, Reader EntryPoint] r => InfoTable -> Sem r InfoTable
|
||||
toReg :: (Members '[Error JuvixError, Reader EntryPoint] r) => InfoTable -> Sem r InfoTable
|
||||
toReg = mapReader fromEntryPoint . mapError (JuvixError @AsmError) . toReg'
|
||||
|
@ -372,7 +372,7 @@ instance PrettyCode ConstructorInfo where
|
||||
ty <- ppCode _constructorType
|
||||
return $ annotate (AnnKind KNameConstructor) (pretty (quoteAsmName _constructorName)) <+> colon <+> ty
|
||||
|
||||
ppInductive :: Member (Reader Options) r => InfoTable -> InductiveInfo -> Sem r (Doc Ann)
|
||||
ppInductive :: (Member (Reader Options) r) => InfoTable -> InductiveInfo -> Sem r (Doc Ann)
|
||||
ppInductive tab InductiveInfo {..} = do
|
||||
ctrs <- mapM (ppCode . lookupConstrInfo tab) _inductiveConstructors
|
||||
return $ kwInductive <+> annotate (AnnKind KNameInductive) (pretty (quoteAsmName _inductiveName)) <+> braces' (vcat (map (<> semi) ctrs))
|
||||
|
@ -10,18 +10,18 @@ import Juvix.Compiler.Backend.Geb.Language
|
||||
|
||||
type CheckingEnv = Context Object
|
||||
|
||||
check' :: Member (Error CheckingError) r => TypedMorphism -> Sem r TypedMorphism
|
||||
check' :: (Member (Error CheckingError) r) => TypedMorphism -> Sem r TypedMorphism
|
||||
check' tyMorph = do
|
||||
runReader (mempty @CheckingEnv) $ check (tyMorph ^. typedMorphism) (tyMorph ^. typedMorphismObject)
|
||||
return tyMorph
|
||||
|
||||
check :: Members '[Reader CheckingEnv, Error CheckingError] r => Morphism -> Object -> Sem r ()
|
||||
check :: (Members '[Reader CheckingEnv, Error CheckingError] r) => Morphism -> Object -> Sem r ()
|
||||
check morph obj' = do
|
||||
ctx <- ask @CheckingEnv
|
||||
obj <- runReader ctx (inferObject morph)
|
||||
checkTypesEqual obj obj'
|
||||
|
||||
checkTypesEqual :: Members '[Reader CheckingEnv, Error CheckingError] r => Object -> Object -> Sem r ()
|
||||
checkTypesEqual :: (Members '[Reader CheckingEnv, Error CheckingError] r) => Object -> Object -> Sem r ()
|
||||
checkTypesEqual obj obj' =
|
||||
unless
|
||||
(obj == obj')
|
||||
@ -33,14 +33,14 @@ checkTypesEqual obj obj' =
|
||||
}
|
||||
)
|
||||
|
||||
checkSameType :: InferEffects r => [Morphism] -> Sem r ()
|
||||
checkSameType :: (InferEffects r) => [Morphism] -> Sem r ()
|
||||
checkSameType = \case
|
||||
[] -> return ()
|
||||
(x : xs) -> do
|
||||
obj <- inferObject x
|
||||
checkListSameType xs obj
|
||||
|
||||
checkListSameType :: InferEffects r => [Morphism] -> Object -> Sem r ()
|
||||
checkListSameType :: (InferEffects r) => [Morphism] -> Object -> Sem r ()
|
||||
checkListSameType morphs obj = mapM_ (`check` obj) morphs
|
||||
|
||||
inferObject' :: Morphism -> Either CheckingError Object
|
||||
@ -48,7 +48,7 @@ inferObject' = run . runError . runReader mempty . inferObject @'[Reader Checkin
|
||||
|
||||
type InferEffects r = Members '[Reader CheckingEnv, Error CheckingError] r
|
||||
|
||||
inferObject :: InferEffects r => Morphism -> Sem r Object
|
||||
inferObject :: (InferEffects r) => Morphism -> Sem r Object
|
||||
inferObject = \case
|
||||
MorphismUnit -> return ObjectTerminal
|
||||
MorphismInteger {} -> return ObjectInteger
|
||||
@ -65,12 +65,12 @@ inferObject = \case
|
||||
MorphismRight b -> inferObjectRight b
|
||||
MorphismFail x -> return $ x ^. failureType
|
||||
|
||||
inferObjectAbsurd :: InferEffects r => Absurd -> Sem r Object
|
||||
inferObjectAbsurd :: (InferEffects r) => Absurd -> Sem r Object
|
||||
inferObjectAbsurd x = do
|
||||
check (x ^. absurdValue) (x ^. absurdType)
|
||||
return ObjectInitial
|
||||
|
||||
inferObjectApplication :: InferEffects r => Application -> Sem r Object
|
||||
inferObjectApplication :: (InferEffects r) => Application -> Sem r Object
|
||||
inferObjectApplication app = do
|
||||
homTy <- inferObject (app ^. applicationLeft)
|
||||
lType <- inferObject (app ^. applicationRight)
|
||||
@ -86,7 +86,7 @@ inferObjectApplication app = do
|
||||
_expectedTypeKind = "hom object"
|
||||
}
|
||||
|
||||
inferObjectLambda :: InferEffects r => Lambda -> Sem r Object
|
||||
inferObjectLambda :: (InferEffects r) => Lambda -> Sem r Object
|
||||
inferObjectLambda l = do
|
||||
let aType = l ^. lambdaVarType
|
||||
ctx <- ask @CheckingEnv
|
||||
@ -101,7 +101,7 @@ inferObjectLambda l = do
|
||||
_homCodomain = bType
|
||||
}
|
||||
|
||||
inferObjectPair :: InferEffects r => Pair -> Sem r Object
|
||||
inferObjectPair :: (InferEffects r) => Pair -> Sem r Object
|
||||
inferObjectPair pair = do
|
||||
lType <- inferObject (pair ^. pairLeft)
|
||||
rType <- inferObject (pair ^. pairRight)
|
||||
@ -112,7 +112,7 @@ inferObjectPair pair = do
|
||||
_productRight = rType
|
||||
}
|
||||
|
||||
inferObjectCase :: InferEffects r => Case -> Sem r Object
|
||||
inferObjectCase :: (InferEffects r) => Case -> Sem r Object
|
||||
inferObjectCase c = do
|
||||
vType <- inferObject (c ^. caseOn)
|
||||
case vType of
|
||||
@ -136,7 +136,7 @@ inferObjectCase c = do
|
||||
_expectedTypeKind = "coproduct"
|
||||
}
|
||||
|
||||
inferObjectFirst :: InferEffects r => First -> Sem r Object
|
||||
inferObjectFirst :: (InferEffects r) => First -> Sem r Object
|
||||
inferObjectFirst p = do
|
||||
pairType <- inferObject (p ^. firstValue)
|
||||
case pairType of
|
||||
@ -150,7 +150,7 @@ inferObjectFirst p = do
|
||||
_expectedTypeKind = "product"
|
||||
}
|
||||
|
||||
inferObjectSecond :: InferEffects r => Second -> Sem r Object
|
||||
inferObjectSecond :: (InferEffects r) => Second -> Sem r Object
|
||||
inferObjectSecond p = do
|
||||
pairType <- inferObject (p ^. secondValue)
|
||||
case pairType of
|
||||
@ -164,12 +164,12 @@ inferObjectSecond p = do
|
||||
_expectedTypeKind = "product"
|
||||
}
|
||||
|
||||
inferObjectVar :: InferEffects r => Var -> Sem r Object
|
||||
inferObjectVar :: (InferEffects r) => Var -> Sem r Object
|
||||
inferObjectVar v = do
|
||||
ctx <- ask @CheckingEnv
|
||||
return $ Context.lookup (v ^. varIndex) ctx
|
||||
|
||||
inferObjectBinop :: InferEffects r => Binop -> Sem r Object
|
||||
inferObjectBinop :: (InferEffects r) => Binop -> Sem r Object
|
||||
inferObjectBinop opApp = do
|
||||
let outTy = objectBinop opApp
|
||||
leftArg = opApp ^. binopLeft
|
||||
@ -199,7 +199,7 @@ inferObjectBinop opApp = do
|
||||
checkSameType args
|
||||
return outTy
|
||||
|
||||
inferObjectLeft :: InferEffects r => LeftInj -> Sem r Object
|
||||
inferObjectLeft :: (InferEffects r) => LeftInj -> Sem r Object
|
||||
inferObjectLeft LeftInj {..} = do
|
||||
lType <- inferObject _leftInjValue
|
||||
return $
|
||||
@ -209,7 +209,7 @@ inferObjectLeft LeftInj {..} = do
|
||||
_coproductRight = _leftInjRightType
|
||||
}
|
||||
|
||||
inferObjectRight :: InferEffects r => RightInj -> Sem r Object
|
||||
inferObjectRight :: (InferEffects r) => RightInj -> Sem r Object
|
||||
inferObjectRight RightInj {..} = do
|
||||
rType <- inferObject _rightInjValue
|
||||
return $
|
||||
|
@ -56,7 +56,7 @@ evalAndOutputMorphism' :: Env -> Morphism -> Either JuvixError Morphism
|
||||
evalAndOutputMorphism' env m = run . runError $ runReader env (evalAndOutputMorphism m)
|
||||
|
||||
evalAndOutputMorphism ::
|
||||
Members '[Reader Env, Error JuvixError] r =>
|
||||
(Members '[Reader Env, Error JuvixError] r) =>
|
||||
Morphism ->
|
||||
Sem r Morphism
|
||||
evalAndOutputMorphism m = do
|
||||
@ -65,7 +65,7 @@ evalAndOutputMorphism m = do
|
||||
|
||||
type EvalEffects r = Members '[Reader Env, Error EvalError] r
|
||||
|
||||
eval :: EvalEffects r => Morphism -> Sem r GebValue
|
||||
eval :: (EvalEffects r) => Morphism -> Sem r GebValue
|
||||
eval morph =
|
||||
case morph of
|
||||
MorphismAbsurd x -> evalAbsurd x
|
||||
@ -83,13 +83,13 @@ eval morph =
|
||||
MorphismVar x -> evalVar x
|
||||
MorphismFail x -> evalFail x
|
||||
|
||||
evalVar :: EvalEffects r => Var -> Sem r GebValue
|
||||
evalVar :: (EvalEffects r) => Var -> Sem r GebValue
|
||||
evalVar var = do
|
||||
ctx <- asks (^. envContext)
|
||||
let val = Context.lookup (var ^. varIndex) ctx
|
||||
return val
|
||||
|
||||
evalAbsurd :: EvalEffects r => Absurd -> Sem r GebValue
|
||||
evalAbsurd :: (EvalEffects r) => Absurd -> Sem r GebValue
|
||||
evalAbsurd morph =
|
||||
throw
|
||||
EvalError
|
||||
@ -98,7 +98,7 @@ evalAbsurd morph =
|
||||
_evalErrorGebExpression = Just $ MorphismAbsurd morph
|
||||
}
|
||||
|
||||
evalPair :: EvalEffects r => Pair -> Sem r GebValue
|
||||
evalPair :: (EvalEffects r) => Pair -> Sem r GebValue
|
||||
evalPair pair = do
|
||||
left <- eval $ pair ^. pairLeft
|
||||
right <- eval $ pair ^. pairRight
|
||||
@ -109,7 +109,7 @@ evalPair pair = do
|
||||
_pairRight = right
|
||||
}
|
||||
|
||||
evalFirst :: EvalEffects r => First -> Sem r GebValue
|
||||
evalFirst :: (EvalEffects r) => First -> Sem r GebValue
|
||||
evalFirst f = do
|
||||
res <- eval $ f ^. firstValue
|
||||
case res of
|
||||
@ -122,7 +122,7 @@ evalFirst f = do
|
||||
_evalErrorGebExpression = Just (MorphismFirst f)
|
||||
}
|
||||
|
||||
evalSecond :: EvalEffects r => Second -> Sem r GebValue
|
||||
evalSecond :: (EvalEffects r) => Second -> Sem r GebValue
|
||||
evalSecond s = do
|
||||
res <- eval $ s ^. secondValue
|
||||
case res of
|
||||
@ -135,7 +135,7 @@ evalSecond s = do
|
||||
_evalErrorGebExpression = Just (MorphismSecond s)
|
||||
}
|
||||
|
||||
evalLeftInj :: EvalEffects r => LeftInj -> Sem r GebValue
|
||||
evalLeftInj :: (EvalEffects r) => LeftInj -> Sem r GebValue
|
||||
evalLeftInj s = do
|
||||
res <- eval $ s ^. leftInjValue
|
||||
return $
|
||||
@ -145,7 +145,7 @@ evalLeftInj s = do
|
||||
_leftInjRightType = s ^. leftInjRightType
|
||||
}
|
||||
|
||||
evalRightInj :: EvalEffects r => RightInj -> Sem r GebValue
|
||||
evalRightInj :: (EvalEffects r) => RightInj -> Sem r GebValue
|
||||
evalRightInj s = do
|
||||
res <- eval $ s ^. rightInjValue
|
||||
return $
|
||||
@ -155,13 +155,13 @@ evalRightInj s = do
|
||||
_rightInjLeftType = s ^. rightInjLeftType
|
||||
}
|
||||
|
||||
evalApp :: EvalEffects r => Application -> Sem r GebValue
|
||||
evalApp :: (EvalEffects r) => Application -> Sem r GebValue
|
||||
evalApp app = do
|
||||
arg <- eval (app ^. applicationRight)
|
||||
apply (app ^. applicationLeft) arg
|
||||
|
||||
apply ::
|
||||
EvalEffects r =>
|
||||
(EvalEffects r) =>
|
||||
Morphism ->
|
||||
GebValue ->
|
||||
Sem r GebValue
|
||||
@ -182,13 +182,13 @@ apply fun' arg = do
|
||||
_evalErrorGebExpression = Nothing
|
||||
}
|
||||
|
||||
evalExtendContext :: EvalEffects r => GebValue -> Morphism -> Sem r GebValue
|
||||
evalExtendContext :: (EvalEffects r) => GebValue -> Morphism -> Sem r GebValue
|
||||
evalExtendContext v m = do
|
||||
ctx <- asks (^. envContext)
|
||||
local (set envContext (Context.cons v ctx)) $
|
||||
eval m
|
||||
|
||||
evalLambda :: EvalEffects r => Lambda -> Sem r GebValue
|
||||
evalLambda :: (EvalEffects r) => Lambda -> Sem r GebValue
|
||||
evalLambda lambda = do
|
||||
ctx <- asks (^. envContext)
|
||||
return $
|
||||
@ -198,7 +198,7 @@ evalLambda lambda = do
|
||||
_valueClosureEnv = ctx
|
||||
}
|
||||
|
||||
evalCase :: EvalEffects r => Case -> Sem r GebValue
|
||||
evalCase :: (EvalEffects r) => Case -> Sem r GebValue
|
||||
evalCase c = do
|
||||
vCaseOn <- eval $ c ^. caseOn
|
||||
case vCaseOn of
|
||||
@ -213,7 +213,7 @@ evalCase c = do
|
||||
}
|
||||
|
||||
evalBinop ::
|
||||
EvalEffects r =>
|
||||
(EvalEffects r) =>
|
||||
Binop ->
|
||||
Sem r GebValue
|
||||
evalBinop binop = do
|
||||
@ -265,7 +265,7 @@ evalBinop binop = do
|
||||
_evalErrorGebExpression = Just (MorphismBinop binop)
|
||||
}
|
||||
|
||||
evalFail :: EvalEffects r => Failure -> Sem r GebValue
|
||||
evalFail :: (EvalEffects r) => Failure -> Sem r GebValue
|
||||
evalFail Failure {..} =
|
||||
throw
|
||||
EvalError
|
||||
|
@ -55,7 +55,7 @@ instance Show EvalError where
|
||||
<> "\n"
|
||||
|
||||
evalError ::
|
||||
Member (Error JuvixError) r =>
|
||||
(Member (Error JuvixError) r) =>
|
||||
Text ->
|
||||
Maybe GebValue ->
|
||||
Maybe Morphism ->
|
||||
|
@ -46,7 +46,7 @@ docLisp opts packageName entryName morph _ =
|
||||
)
|
||||
|
||||
class PrettyCode c where
|
||||
ppCode :: Member (Reader Options) r => c -> Sem r (Doc Ann)
|
||||
ppCode :: (Member (Reader Options) r) => c -> Sem r (Doc Ann)
|
||||
|
||||
ppCode' :: (PrettyCode c) => Options -> c -> Doc Ann
|
||||
ppCode' opts = run . runReader opts . ppCode
|
||||
|
@ -20,7 +20,7 @@ data LispDefParameter = LispDefParameter
|
||||
makeLenses ''LispDefParameter
|
||||
|
||||
fromSource ::
|
||||
Member (Error JuvixError) r =>
|
||||
(Member (Error JuvixError) r) =>
|
||||
Path Abs File ->
|
||||
Text ->
|
||||
Sem r Geb.Expression
|
||||
|
@ -194,14 +194,14 @@ ppCodeHtml ::
|
||||
ppCodeHtml opts = ppCodeHtmlHelper opts Nothing
|
||||
|
||||
ppModuleSrcHtml ::
|
||||
Members '[Reader HtmlOptions] r =>
|
||||
(Members '[Reader HtmlOptions] r) =>
|
||||
Options ->
|
||||
Comments ->
|
||||
Module 'Scoped 'ModuleTop ->
|
||||
Sem r Html
|
||||
ppModuleSrcHtml = ppCodeHtmlComments
|
||||
|
||||
docToHtml :: Members '[Reader HtmlOptions] r => Doc Ann -> Sem r Html
|
||||
docToHtml :: (Members '[Reader HtmlOptions] r) => Doc Ann -> Sem r Html
|
||||
docToHtml d = ppCodeHtml' <$> ask
|
||||
where
|
||||
ppCodeHtml' :: HtmlOptions -> Html
|
||||
|
@ -12,7 +12,7 @@ import Juvix.Compiler.Backend.VampIR.Pretty.Options
|
||||
import Juvix.Data.PPOutput
|
||||
import Prettyprinter.Render.Terminal qualified as Ansi
|
||||
|
||||
ppOutDefault :: PrettyCode c => c -> AnsiText
|
||||
ppOutDefault :: (PrettyCode c) => c -> AnsiText
|
||||
ppOutDefault = mkAnsiText . PPOutput . doc defaultOptions
|
||||
|
||||
ppOut :: (CanonicalProjection a Options, PrettyCode c) => a -> c -> AnsiText
|
||||
@ -21,8 +21,8 @@ ppOut o = mkAnsiText . PPOutput . doc (project o)
|
||||
ppTrace' :: (CanonicalProjection a Options, PrettyCode c) => a -> c -> Text
|
||||
ppTrace' opts = Ansi.renderStrict . reAnnotateS stylize . layoutPretty defaultLayoutOptions . doc (project opts)
|
||||
|
||||
ppTrace :: PrettyCode c => c -> Text
|
||||
ppTrace :: (PrettyCode c) => c -> Text
|
||||
ppTrace = ppTrace' traceOptions
|
||||
|
||||
ppPrint :: PrettyCode c => c -> Text
|
||||
ppPrint :: (PrettyCode c) => c -> Text
|
||||
ppPrint = show . ppOutDefault
|
||||
|
@ -9,9 +9,9 @@ import Juvix.Data.CodeAnn
|
||||
import Juvix.Data.NameKind
|
||||
|
||||
class PrettyCode c where
|
||||
ppCode :: Member (Reader Options) r => c -> Sem r (Doc Ann)
|
||||
ppCode :: (Member (Reader Options) r) => c -> Sem r (Doc Ann)
|
||||
|
||||
doc :: PrettyCode c => Options -> c -> Doc Ann
|
||||
doc :: (PrettyCode c) => Options -> c -> Doc Ann
|
||||
doc opts x =
|
||||
run $
|
||||
runReader opts $
|
||||
|
@ -57,7 +57,7 @@ registerIf f = do
|
||||
_funInfoFreeTypeVars = [vart]
|
||||
}
|
||||
|
||||
registerOr :: Members '[Builtins, NameIdGen] r => FunctionDef -> Sem r ()
|
||||
registerOr :: (Members '[Builtins, NameIdGen] r) => FunctionDef -> Sem r ()
|
||||
registerOr f = do
|
||||
bool_ <- getBuiltinName (getLoc f) BuiltinBool
|
||||
true_ <- toExpression <$> getBuiltinName (getLoc f) BuiltinBoolTrue
|
||||
@ -82,7 +82,7 @@ registerOr f = do
|
||||
_funInfoFreeTypeVars = []
|
||||
}
|
||||
|
||||
registerAnd :: Members '[Builtins, NameIdGen] r => FunctionDef -> Sem r ()
|
||||
registerAnd :: (Members '[Builtins, NameIdGen] r) => FunctionDef -> Sem r ()
|
||||
registerAnd f = do
|
||||
bool_ <- getBuiltinName (getLoc f) BuiltinBool
|
||||
true_ <- toExpression <$> getBuiltinName (getLoc f) BuiltinBoolTrue
|
||||
|
@ -5,7 +5,7 @@ import Juvix.Compiler.Builtins.Effect
|
||||
import Juvix.Compiler.Internal.Extra
|
||||
import Juvix.Prelude
|
||||
|
||||
registerTrace :: Members '[Builtins, NameIdGen] r => AxiomDef -> Sem r ()
|
||||
registerTrace :: (Members '[Builtins, NameIdGen] r) => AxiomDef -> Sem r ()
|
||||
registerTrace f = do
|
||||
let ftype = f ^. axiomType
|
||||
u = ExpressionUniverse smallUniverseNoLoc
|
||||
@ -17,7 +17,7 @@ registerTrace f = do
|
||||
(error "trace must be of type {A : Type} -> A -> A")
|
||||
registerBuiltin BuiltinTrace (f ^. axiomName)
|
||||
|
||||
registerFail :: Members '[Builtins, NameIdGen] r => AxiomDef -> Sem r ()
|
||||
registerFail :: (Members '[Builtins, NameIdGen] r) => AxiomDef -> Sem r ()
|
||||
registerFail f = do
|
||||
let ftype = f ^. axiomType
|
||||
u = ExpressionUniverse smallUniverseNoLoc
|
||||
|
@ -82,7 +82,7 @@ data FunInfo = FunInfo
|
||||
makeLenses ''FunInfo
|
||||
|
||||
registerFun ::
|
||||
Members '[Builtins, NameIdGen] r =>
|
||||
(Members '[Builtins, NameIdGen] r) =>
|
||||
FunInfo ->
|
||||
Sem r ()
|
||||
registerFun fi = do
|
||||
|
@ -4,7 +4,7 @@ import Juvix.Compiler.Builtins.Effect
|
||||
import Juvix.Compiler.Internal.Extra
|
||||
import Juvix.Prelude
|
||||
|
||||
registerIntDef :: Member Builtins r => InductiveDef -> Sem r ()
|
||||
registerIntDef :: (Member Builtins r) => InductiveDef -> Sem r ()
|
||||
registerIntDef d = do
|
||||
unless (null (d ^. inductiveParameters)) (error "Int should have no type parameters")
|
||||
unless (isSmallUniverse' (d ^. inductiveType)) (error "Int should be in the small universe")
|
||||
@ -23,14 +23,14 @@ registerIntCtor ctor d@ConstructorDef {..} = do
|
||||
unless (ty === (nat --> int)) (error (ctorName ^. nameText <> " has the wrong type"))
|
||||
registerBuiltin ctor ctorName
|
||||
|
||||
registerIntToString :: Member Builtins r => AxiomDef -> Sem r ()
|
||||
registerIntToString :: (Member Builtins r) => AxiomDef -> Sem r ()
|
||||
registerIntToString f = do
|
||||
string_ <- getBuiltinName (getLoc f) BuiltinString
|
||||
int <- getBuiltinName (getLoc f) BuiltinInt
|
||||
unless (f ^. axiomType === (int --> string_)) (error "intToString has the wrong type signature")
|
||||
registerBuiltin BuiltinIntToString (f ^. axiomName)
|
||||
|
||||
registerIntEq :: forall r. Members '[Builtins, NameIdGen] r => FunctionDef -> Sem r ()
|
||||
registerIntEq :: forall r. (Members '[Builtins, NameIdGen] r) => FunctionDef -> Sem r ()
|
||||
registerIntEq f = do
|
||||
int <- builtinName BuiltinInt
|
||||
ofNat <- toExpression <$> builtinName BuiltinIntOfNat
|
||||
@ -64,10 +64,10 @@ registerIntEq f = do
|
||||
_funInfoFreeTypeVars = []
|
||||
}
|
||||
where
|
||||
builtinName :: IsBuiltin a => a -> Sem r Name
|
||||
builtinName :: (IsBuiltin a) => a -> Sem r Name
|
||||
builtinName = getBuiltinName (getLoc f)
|
||||
|
||||
registerIntSubNat :: forall r. Members '[Builtins, NameIdGen] r => FunctionDef -> Sem r ()
|
||||
registerIntSubNat :: forall r. (Members '[Builtins, NameIdGen] r) => FunctionDef -> Sem r ()
|
||||
registerIntSubNat f = do
|
||||
let loc = getLoc f
|
||||
int <- getBuiltinName loc BuiltinInt
|
||||
@ -75,7 +75,7 @@ registerIntSubNat f = do
|
||||
unless (f ^. funDefType === (nat --> nat --> int)) (error "int-sub-nat has the wrong type signature")
|
||||
registerBuiltin BuiltinIntSubNat (f ^. funDefName)
|
||||
|
||||
registerIntPlus :: forall r. Members '[Builtins, NameIdGen] r => FunctionDef -> Sem r ()
|
||||
registerIntPlus :: forall r. (Members '[Builtins, NameIdGen] r) => FunctionDef -> Sem r ()
|
||||
registerIntPlus f = do
|
||||
let loc = getLoc f
|
||||
int <- getBuiltinName loc BuiltinInt
|
||||
@ -109,7 +109,7 @@ registerIntPlus f = do
|
||||
_funInfoFreeTypeVars = []
|
||||
}
|
||||
|
||||
registerIntNegNat :: forall r. Members '[Builtins, NameIdGen] r => FunctionDef -> Sem r ()
|
||||
registerIntNegNat :: forall r. (Members '[Builtins, NameIdGen] r) => FunctionDef -> Sem r ()
|
||||
registerIntNegNat f = do
|
||||
int <- builtinName BuiltinInt
|
||||
nat <- builtinName BuiltinNat
|
||||
@ -136,10 +136,10 @@ registerIntNegNat f = do
|
||||
_funInfoFreeTypeVars = []
|
||||
}
|
||||
where
|
||||
builtinName :: IsBuiltin a => a -> Sem r Name
|
||||
builtinName :: (IsBuiltin a) => a -> Sem r Name
|
||||
builtinName = getBuiltinName (getLoc f)
|
||||
|
||||
registerIntNeg :: forall r. Members '[Builtins, NameIdGen] r => FunctionDef -> Sem r ()
|
||||
registerIntNeg :: forall r. (Members '[Builtins, NameIdGen] r) => FunctionDef -> Sem r ()
|
||||
registerIntNeg f = do
|
||||
int <- builtinName BuiltinInt
|
||||
ofNat <- toExpression <$> builtinName BuiltinIntOfNat
|
||||
@ -165,10 +165,10 @@ registerIntNeg f = do
|
||||
_funInfoFreeTypeVars = []
|
||||
}
|
||||
where
|
||||
builtinName :: IsBuiltin a => a -> Sem r Name
|
||||
builtinName :: (IsBuiltin a) => a -> Sem r Name
|
||||
builtinName = getBuiltinName (getLoc f)
|
||||
|
||||
registerIntMul :: forall r. Members '[Builtins, NameIdGen] r => FunctionDef -> Sem r ()
|
||||
registerIntMul :: forall r. (Members '[Builtins, NameIdGen] r) => FunctionDef -> Sem r ()
|
||||
registerIntMul f = do
|
||||
int <- builtinName BuiltinInt
|
||||
ofNat <- toExpression <$> builtinName BuiltinIntOfNat
|
||||
@ -199,10 +199,10 @@ registerIntMul f = do
|
||||
_funInfoFreeTypeVars = []
|
||||
}
|
||||
where
|
||||
builtinName :: IsBuiltin a => a -> Sem r Name
|
||||
builtinName :: (IsBuiltin a) => a -> Sem r Name
|
||||
builtinName = getBuiltinName (getLoc f)
|
||||
|
||||
registerIntDiv :: forall r. Members '[Builtins, NameIdGen] r => FunctionDef -> Sem r ()
|
||||
registerIntDiv :: forall r. (Members '[Builtins, NameIdGen] r) => FunctionDef -> Sem r ()
|
||||
registerIntDiv f = do
|
||||
int <- builtinName BuiltinInt
|
||||
ofNat <- toExpression <$> builtinName BuiltinIntOfNat
|
||||
@ -233,10 +233,10 @@ registerIntDiv f = do
|
||||
_funInfoFreeTypeVars = []
|
||||
}
|
||||
where
|
||||
builtinName :: IsBuiltin a => a -> Sem r Name
|
||||
builtinName :: (IsBuiltin a) => a -> Sem r Name
|
||||
builtinName = getBuiltinName (getLoc f)
|
||||
|
||||
registerIntMod :: forall r. Members '[Builtins, NameIdGen] r => FunctionDef -> Sem r ()
|
||||
registerIntMod :: forall r. (Members '[Builtins, NameIdGen] r) => FunctionDef -> Sem r ()
|
||||
registerIntMod f = do
|
||||
int <- builtinName BuiltinInt
|
||||
ofNat <- toExpression <$> builtinName BuiltinIntOfNat
|
||||
@ -267,10 +267,10 @@ registerIntMod f = do
|
||||
_funInfoFreeTypeVars = []
|
||||
}
|
||||
where
|
||||
builtinName :: IsBuiltin a => a -> Sem r Name
|
||||
builtinName :: (IsBuiltin a) => a -> Sem r Name
|
||||
builtinName = getBuiltinName (getLoc f)
|
||||
|
||||
registerIntSub :: forall r. Members '[Builtins, NameIdGen] r => FunctionDef -> Sem r ()
|
||||
registerIntSub :: forall r. (Members '[Builtins, NameIdGen] r) => FunctionDef -> Sem r ()
|
||||
registerIntSub f = do
|
||||
int <- builtinName BuiltinInt
|
||||
neg <- toExpression <$> builtinName BuiltinIntNeg
|
||||
@ -295,10 +295,10 @@ registerIntSub f = do
|
||||
_funInfoFreeTypeVars = []
|
||||
}
|
||||
where
|
||||
builtinName :: IsBuiltin a => a -> Sem r Name
|
||||
builtinName :: (IsBuiltin a) => a -> Sem r Name
|
||||
builtinName = getBuiltinName (getLoc f)
|
||||
|
||||
registerIntNonNeg :: forall r. Members '[Builtins, NameIdGen] r => FunctionDef -> Sem r ()
|
||||
registerIntNonNeg :: forall r. (Members '[Builtins, NameIdGen] r) => FunctionDef -> Sem r ()
|
||||
registerIntNonNeg f = do
|
||||
int <- builtinName BuiltinInt
|
||||
bool_ <- builtinName BuiltinBool
|
||||
@ -327,17 +327,17 @@ registerIntNonNeg f = do
|
||||
_funInfoFreeTypeVars = []
|
||||
}
|
||||
where
|
||||
builtinName :: IsBuiltin a => a -> Sem r Name
|
||||
builtinName :: (IsBuiltin a) => a -> Sem r Name
|
||||
builtinName = getBuiltinName (getLoc f)
|
||||
|
||||
registerIntPrint :: Members '[Builtins] r => AxiomDef -> Sem r ()
|
||||
registerIntPrint :: (Members '[Builtins] r) => AxiomDef -> Sem r ()
|
||||
registerIntPrint f = do
|
||||
int <- getBuiltinName (getLoc f) BuiltinInt
|
||||
io <- getBuiltinName (getLoc f) BuiltinIO
|
||||
unless (f ^. axiomType === (int --> io)) (error "Int print has the wrong type signature")
|
||||
registerBuiltin BuiltinIntPrint (f ^. axiomName)
|
||||
|
||||
registerIntLe :: forall r. Members '[Builtins, NameIdGen] r => FunctionDef -> Sem r ()
|
||||
registerIntLe :: forall r. (Members '[Builtins, NameIdGen] r) => FunctionDef -> Sem r ()
|
||||
registerIntLe f = do
|
||||
int <- builtinName BuiltinInt
|
||||
bool_ <- builtinName BuiltinBool
|
||||
@ -364,10 +364,10 @@ registerIntLe f = do
|
||||
_funInfoFreeTypeVars = []
|
||||
}
|
||||
where
|
||||
builtinName :: IsBuiltin a => a -> Sem r Name
|
||||
builtinName :: (IsBuiltin a) => a -> Sem r Name
|
||||
builtinName = getBuiltinName (getLoc f)
|
||||
|
||||
registerIntLt :: forall r. Members '[Builtins, NameIdGen] r => FunctionDef -> Sem r ()
|
||||
registerIntLt :: forall r. (Members '[Builtins, NameIdGen] r) => FunctionDef -> Sem r ()
|
||||
registerIntLt f = do
|
||||
int <- builtinName BuiltinInt
|
||||
bool_ <- builtinName BuiltinBool
|
||||
@ -397,5 +397,5 @@ registerIntLt f = do
|
||||
_funInfoFreeTypeVars = []
|
||||
}
|
||||
where
|
||||
builtinName :: IsBuiltin a => a -> Sem r Name
|
||||
builtinName :: (IsBuiltin a) => a -> Sem r Name
|
||||
builtinName = getBuiltinName (getLoc f)
|
||||
|
@ -5,7 +5,7 @@ import Juvix.Compiler.Internal.Extra
|
||||
import Juvix.Compiler.Internal.Pretty
|
||||
import Juvix.Prelude
|
||||
|
||||
registerListDef :: Member Builtins r => InductiveDef -> Sem r ()
|
||||
registerListDef :: (Member Builtins r) => InductiveDef -> Sem r ()
|
||||
registerListDef d = do
|
||||
unless (isSmallUniverse' (d ^. inductiveType)) (error "Lists should be in the small universe")
|
||||
registerBuiltin BuiltinList (d ^. inductiveName)
|
||||
@ -18,7 +18,7 @@ registerListDef d = do
|
||||
[v] -> v ^. inductiveParamName
|
||||
_ -> error "List should have exactly one type parameter"
|
||||
|
||||
registerNil :: Member Builtins r => VarName -> ConstructorDef -> Sem r ()
|
||||
registerNil :: (Member Builtins r) => VarName -> ConstructorDef -> Sem r ()
|
||||
registerNil a d@ConstructorDef {..} = do
|
||||
let nil = _inductiveConstructorName
|
||||
ty = _inductiveConstructorType
|
||||
@ -27,7 +27,7 @@ registerNil a d@ConstructorDef {..} = do
|
||||
unless (ty === nilty) (error $ "nil has the wrong type " <> ppTrace ty <> " | " <> ppTrace nilty)
|
||||
registerBuiltin BuiltinListNil nil
|
||||
|
||||
registerCons :: Member Builtins r => VarName -> ConstructorDef -> Sem r ()
|
||||
registerCons :: (Member Builtins r) => VarName -> ConstructorDef -> Sem r ()
|
||||
registerCons a d@ConstructorDef {..} = do
|
||||
let cons_ = _inductiveConstructorName
|
||||
ty = _inductiveConstructorType
|
||||
|
@ -156,7 +156,7 @@ registerNatUDiv f = do
|
||||
_funInfoFreeTypeVars = []
|
||||
}
|
||||
|
||||
registerNatDiv :: Members '[Builtins, NameIdGen] r => FunctionDef -> Sem r ()
|
||||
registerNatDiv :: (Members '[Builtins, NameIdGen] r) => FunctionDef -> Sem r ()
|
||||
registerNatDiv f = do
|
||||
nat <- getBuiltinName (getLoc f) BuiltinNat
|
||||
suc <- toExpression <$> getBuiltinName (getLoc f) BuiltinNatSuc
|
||||
|
@ -48,7 +48,7 @@ runHighlightBuilder = runState emptyHighlightInput
|
||||
ignoreHighlightBuilder :: Sem (HighlightBuilder ': r) a -> Sem r a
|
||||
ignoreHighlightBuilder = evalState emptyHighlightInput
|
||||
|
||||
runJuvixError :: Members '[HighlightBuilder] r => Sem (Error JuvixError ': r) a -> Sem r (Either JuvixError a)
|
||||
runJuvixError :: (Members '[HighlightBuilder] r) => Sem (Error JuvixError ': r) a -> Sem r (Either JuvixError a)
|
||||
runJuvixError m = do
|
||||
x <- runError m
|
||||
case x of
|
||||
|
@ -18,7 +18,7 @@ defaultOptions = Options
|
||||
ppDocDefault :: Scoped.AName -> Maybe Internal.Expression -> Maybe (Judoc 'Scoped) -> Maybe (Doc CodeAnn)
|
||||
ppDocDefault n ty = run . runReader defaultOptions . ppDoc n ty
|
||||
|
||||
ppInternal :: Members '[Reader Options] r => Internal.PrettyCode c => c -> Sem r (Doc CodeAnn)
|
||||
ppInternal :: (Members '[Reader Options] r) => (Internal.PrettyCode c) => c -> Sem r (Doc CodeAnn)
|
||||
ppInternal c = do
|
||||
iopts <- mkOpts <$> ask
|
||||
return (Internal.runPrettyCode iopts c)
|
||||
@ -26,7 +26,7 @@ ppInternal c = do
|
||||
mkOpts :: Options -> Internal.Options
|
||||
mkOpts = const (Internal.defaultOptions)
|
||||
|
||||
ppScoped :: Members '[Reader Options] r => Scoped.PrettyPrint c => c -> Sem r (Doc CodeAnn)
|
||||
ppScoped :: (Members '[Reader Options] r) => (Scoped.PrettyPrint c) => c -> Sem r (Doc CodeAnn)
|
||||
ppScoped c = do
|
||||
iopts <- mkOpts <$> ask
|
||||
return (Scoped.docNoComments iopts c)
|
||||
@ -34,7 +34,7 @@ ppScoped c = do
|
||||
mkOpts :: Options -> Scoped.Options
|
||||
mkOpts = const (Scoped.defaultOptions)
|
||||
|
||||
ppDoc :: Members '[Reader Options] r => Scoped.AName -> Maybe Internal.Expression -> Maybe (Judoc 'Scoped) -> Sem r (Maybe (Doc CodeAnn))
|
||||
ppDoc :: (Members '[Reader Options] r) => Scoped.AName -> Maybe Internal.Expression -> Maybe (Judoc 'Scoped) -> Sem r (Maybe (Doc CodeAnn))
|
||||
ppDoc n ty j = do
|
||||
n' <- ppScoped n
|
||||
ty' <- fmap ((n' <+> kwColon) <+>) <$> mapM ppInternal ty
|
||||
@ -44,7 +44,7 @@ ppDoc n ty j = do
|
||||
(Just jty', Just jj') -> return (jty' <+> line <> line <> jj')
|
||||
_ -> ty' <|> j'
|
||||
|
||||
ppJudoc :: forall r. Members '[Reader Options] r => Judoc 'Scoped -> Sem r (Doc CodeAnn)
|
||||
ppJudoc :: forall r. (Members '[Reader Options] r) => Judoc 'Scoped -> Sem r (Doc CodeAnn)
|
||||
ppJudoc (Judoc bs) = do
|
||||
void (ask @Options) -- to suppress redundant constraint warning
|
||||
ppGroups bs
|
||||
@ -52,7 +52,7 @@ ppJudoc (Judoc bs) = do
|
||||
ppGroups :: NonEmpty (JudocGroup 'Scoped) -> Sem r (Doc CodeAnn)
|
||||
ppGroups = fmap vsep . mapM ppGroup
|
||||
|
||||
ppBlocks :: Traversable l => l (JudocBlock 'Scoped) -> Sem r (Doc CodeAnn)
|
||||
ppBlocks :: (Traversable l) => l (JudocBlock 'Scoped) -> Sem r (Doc CodeAnn)
|
||||
ppBlocks = fmap vsep2 . mapM ppBlock
|
||||
|
||||
ppParagraphBlock :: JudocBlockParagraph 'Scoped -> Sem r (Doc CodeAnn)
|
||||
|
@ -165,10 +165,10 @@ addGenericProperties (WithRange i props) =
|
||||
mkItem :: GenericProperty -> (SExp, SExp)
|
||||
mkItem GenericProperty {..} = (Symbol _gpropProperty, _gpropValue)
|
||||
|
||||
putProperty :: IsProperty a => WithRange a -> SExp
|
||||
putProperty :: (IsProperty a) => WithRange a -> SExp
|
||||
putProperty = addGenericProperties . fmap toProperties
|
||||
|
||||
putPropertyLoc :: IsProperty a => WithLoc a -> SExp
|
||||
putPropertyLoc :: (IsProperty a) => WithLoc a -> SExp
|
||||
putPropertyLoc (WithLoc i a) = putProperty (WithRange i' a)
|
||||
where
|
||||
i' :: PointInterval
|
||||
|
@ -58,7 +58,7 @@ renderEmacs s =
|
||||
_stateText = mempty,
|
||||
_stateProperties = []
|
||||
}
|
||||
go :: Members '[State RenderState] r => SimpleDocStream EmacsProperty -> Sem r ()
|
||||
go :: (Members '[State RenderState] r) => SimpleDocStream EmacsProperty -> Sem r ()
|
||||
go = \case
|
||||
SFail -> error "when is this supposed to happen?"
|
||||
SEmpty -> do
|
||||
|
@ -15,7 +15,7 @@ data InfoTableBuilder m a where
|
||||
RegisterConstructor :: S.Symbol -> ConstructorDef 'Scoped -> InfoTableBuilder m ()
|
||||
RegisterInductive :: InductiveDef 'Scoped -> InfoTableBuilder m ()
|
||||
RegisterFunctionDef :: FunctionDef 'Scoped -> InfoTableBuilder m ()
|
||||
RegisterName :: HasLoc c => S.Name' c -> InfoTableBuilder m ()
|
||||
RegisterName :: (HasLoc c) => S.Name' c -> InfoTableBuilder m ()
|
||||
RegisterScopedIden :: ScopedIden -> InfoTableBuilder m ()
|
||||
RegisterModule :: Module 'Scoped 'ModuleTop -> InfoTableBuilder m ()
|
||||
RegisterFixity :: FixityDef -> InfoTableBuilder m ()
|
||||
@ -25,10 +25,10 @@ data InfoTableBuilder m a where
|
||||
|
||||
makeSem ''InfoTableBuilder
|
||||
|
||||
registerDoc :: Members '[HighlightBuilder] r => NameId -> Maybe (Judoc 'Scoped) -> Sem r ()
|
||||
registerDoc :: (Members '[HighlightBuilder] r) => NameId -> Maybe (Judoc 'Scoped) -> Sem r ()
|
||||
registerDoc k md = modify (set (highlightDoc . at k) md)
|
||||
|
||||
toState :: Members '[HighlightBuilder] r => Sem (InfoTableBuilder ': r) a -> Sem (State InfoTable ': r) a
|
||||
toState :: (Members '[HighlightBuilder] r) => Sem (InfoTableBuilder ': r) a -> Sem (State InfoTable ': r) a
|
||||
toState = reinterpret $ \case
|
||||
RegisterAxiom d ->
|
||||
let ref = d ^. axiomName . S.nameId
|
||||
@ -81,10 +81,10 @@ toState = reinterpret $ \case
|
||||
runInfoTableBuilderRepl :: InfoTable -> Sem (InfoTableBuilder ': r) a -> Sem r (InfoTable, a)
|
||||
runInfoTableBuilderRepl tab = ignoreHighlightBuilder . runInfoTableBuilder tab . raiseUnder
|
||||
|
||||
runInfoTableBuilder :: Members '[HighlightBuilder] r => InfoTable -> Sem (InfoTableBuilder ': r) a -> Sem r (InfoTable, a)
|
||||
runInfoTableBuilder :: (Members '[HighlightBuilder] r) => InfoTable -> Sem (InfoTableBuilder ': r) a -> Sem r (InfoTable, a)
|
||||
runInfoTableBuilder tab = runState tab . toState
|
||||
|
||||
ignoreInfoTableBuilder :: Members '[HighlightBuilder] r => Sem (InfoTableBuilder ': r) a -> Sem r a
|
||||
ignoreInfoTableBuilder :: (Members '[HighlightBuilder] r) => Sem (InfoTableBuilder ': r) a -> Sem r a
|
||||
ignoreInfoTableBuilder = evalState emptyInfoTable . toState
|
||||
|
||||
anameFromScopedIden :: ScopedIden -> AName
|
||||
|
@ -87,7 +87,7 @@ topModulePathToName (TopModulePath ms m) = case nonEmpty ms of
|
||||
Nothing -> NameUnqualified m
|
||||
Just ms' -> NameQualified (QualifiedName (SymbolPath ms') m)
|
||||
|
||||
topModulePathToDottedPath :: IsString s => TopModulePath -> s
|
||||
topModulePathToDottedPath :: (IsString s) => TopModulePath -> s
|
||||
topModulePathToDottedPath (TopModulePath l r) =
|
||||
fromText . mconcat . intersperse "." . map (^. symbolText) $ l ++ [r]
|
||||
|
||||
|
@ -33,10 +33,10 @@ makeLenses ''BuilderState
|
||||
makeSem ''NameSignatureBuilder
|
||||
|
||||
class HasNameSignature d where
|
||||
addArgs :: Members '[NameSignatureBuilder] r => d -> Sem r ()
|
||||
addArgs :: (Members '[NameSignatureBuilder] r) => d -> Sem r ()
|
||||
|
||||
instance HasNameSignature (AxiomDef 'Parsed) where
|
||||
addArgs :: Members '[NameSignatureBuilder] r => AxiomDef 'Parsed -> Sem r ()
|
||||
addArgs :: (Members '[NameSignatureBuilder] r) => AxiomDef 'Parsed -> Sem r ()
|
||||
addArgs a = addAtoms (a ^. axiomType)
|
||||
|
||||
instance HasNameSignature (FunctionDef 'Parsed) where
|
||||
@ -47,7 +47,7 @@ instance HasNameSignature (FunctionDef 'Parsed) where
|
||||
instance HasNameSignature (InductiveDef 'Parsed, ConstructorDef 'Parsed) where
|
||||
addArgs ::
|
||||
forall r.
|
||||
Members '[NameSignatureBuilder] r =>
|
||||
(Members '[NameSignatureBuilder] r) =>
|
||||
(InductiveDef 'Parsed, ConstructorDef 'Parsed) ->
|
||||
Sem r ()
|
||||
addArgs (i, c) = do
|
||||
@ -106,7 +106,7 @@ fromBuilderState b =
|
||||
| Just i <- b ^. stateCurrentImplicit = (NameBlock (b ^. stateCurrentBlock) i :)
|
||||
| otherwise = id
|
||||
|
||||
addAtoms :: forall r. Members '[NameSignatureBuilder] r => ExpressionAtoms 'Parsed -> Sem r ()
|
||||
addAtoms :: forall r. (Members '[NameSignatureBuilder] r) => ExpressionAtoms 'Parsed -> Sem r ()
|
||||
addAtoms atoms = addAtom . (^. expressionAtoms . _head1) $ atoms
|
||||
where
|
||||
addAtom :: ExpressionAtom 'Parsed -> Sem r ()
|
||||
@ -124,16 +124,16 @@ addAtoms atoms = addAtom . (^. expressionAtoms . _head1) $ atoms
|
||||
FunctionParameterName s -> addSymbol _paramImplicit s
|
||||
FunctionParameterWildcard {} -> endBuild
|
||||
|
||||
addInductiveParams' :: Members '[NameSignatureBuilder] r => IsImplicit -> InductiveParameters 'Parsed -> Sem r ()
|
||||
addInductiveParams' :: (Members '[NameSignatureBuilder] r) => IsImplicit -> InductiveParameters 'Parsed -> Sem r ()
|
||||
addInductiveParams' i a = forM_ (a ^. inductiveParametersNames) (addSymbol i)
|
||||
|
||||
addInductiveParams :: Members '[NameSignatureBuilder] r => InductiveParameters 'Parsed -> Sem r ()
|
||||
addInductiveParams :: (Members '[NameSignatureBuilder] r) => InductiveParameters 'Parsed -> Sem r ()
|
||||
addInductiveParams = addInductiveParams' Explicit
|
||||
|
||||
addConstructorParams :: Members '[NameSignatureBuilder] r => InductiveParameters 'Parsed -> Sem r ()
|
||||
addConstructorParams :: (Members '[NameSignatureBuilder] r) => InductiveParameters 'Parsed -> Sem r ()
|
||||
addConstructorParams = addInductiveParams' Implicit
|
||||
|
||||
addSigArg :: Members '[NameSignatureBuilder] r => SigArg 'Parsed -> Sem r ()
|
||||
addSigArg :: (Members '[NameSignatureBuilder] r) => SigArg 'Parsed -> Sem r ()
|
||||
addSigArg a = forM_ (a ^. sigArgNames) $ \case
|
||||
ArgumentSymbol s -> addSymbol (a ^. sigArgImplicit) s
|
||||
ArgumentWildcard {} -> return ()
|
||||
|
@ -22,7 +22,7 @@ data InfoTableBuilder m a where
|
||||
|
||||
makeSem ''InfoTableBuilder
|
||||
|
||||
registerKeyword :: Member InfoTableBuilder r => KeywordRef -> Sem r KeywordRef
|
||||
registerKeyword :: (Member InfoTableBuilder r) => KeywordRef -> Sem r KeywordRef
|
||||
registerKeyword r =
|
||||
r
|
||||
<$ registerItem
|
||||
@ -36,7 +36,7 @@ registerKeyword r =
|
||||
KeywordTypeJudoc -> ParsedTagJudoc
|
||||
KeywordTypeDelimiter -> ParsedTagDelimiter
|
||||
|
||||
registerDelimiter :: Member InfoTableBuilder r => Interval -> Sem r ()
|
||||
registerDelimiter :: (Member InfoTableBuilder r) => Interval -> Sem r ()
|
||||
registerDelimiter i =
|
||||
registerItem
|
||||
ParsedItem
|
||||
@ -44,7 +44,7 @@ registerDelimiter i =
|
||||
_parsedTag = ParsedTagDelimiter
|
||||
}
|
||||
|
||||
registerJudocText :: Member InfoTableBuilder r => Interval -> Sem r ()
|
||||
registerJudocText :: (Member InfoTableBuilder r) => Interval -> Sem r ()
|
||||
registerJudocText i =
|
||||
registerItem
|
||||
ParsedItem
|
||||
@ -52,7 +52,7 @@ registerJudocText i =
|
||||
_parsedTag = ParsedTagJudoc
|
||||
}
|
||||
|
||||
registerPragmas :: Member InfoTableBuilder r => Interval -> Sem r ()
|
||||
registerPragmas :: (Member InfoTableBuilder r) => Interval -> Sem r ()
|
||||
registerPragmas i =
|
||||
registerItem
|
||||
ParsedItem
|
||||
@ -60,7 +60,7 @@ registerPragmas i =
|
||||
_parsedTag = ParsedTagComment
|
||||
}
|
||||
|
||||
registerLiteral :: Member InfoTableBuilder r => LiteralLoc -> Sem r LiteralLoc
|
||||
registerLiteral :: (Member InfoTableBuilder r) => LiteralLoc -> Sem r LiteralLoc
|
||||
registerLiteral l =
|
||||
l
|
||||
<$ registerItem
|
||||
@ -81,13 +81,13 @@ build st =
|
||||
_infoParsedModules = st ^. stateModules
|
||||
}
|
||||
|
||||
registerItem' :: Members '[HighlightBuilder] r => ParsedItem -> Sem r ()
|
||||
registerItem' :: (Members '[HighlightBuilder] r) => ParsedItem -> Sem r ()
|
||||
registerItem' i = modify' (over highlightParsed (i :))
|
||||
|
||||
runParserInfoTableBuilderRepl :: BuilderState -> Sem (InfoTableBuilder ': r) a -> Sem r (BuilderState, a)
|
||||
runParserInfoTableBuilderRepl st = ignoreHighlightBuilder . runParserInfoTableBuilder' st . raiseUnder
|
||||
|
||||
runParserInfoTableBuilder' :: Members '[HighlightBuilder] r => BuilderState -> Sem (InfoTableBuilder ': r) a -> Sem r (BuilderState, a)
|
||||
runParserInfoTableBuilder' :: (Members '[HighlightBuilder] r) => BuilderState -> Sem (InfoTableBuilder ': r) a -> Sem r (BuilderState, a)
|
||||
runParserInfoTableBuilder' s =
|
||||
runState s
|
||||
. reinterpret
|
||||
@ -107,7 +107,7 @@ runParserInfoTableBuilder' s =
|
||||
}
|
||||
)
|
||||
|
||||
runParserInfoTableBuilder :: Members '[HighlightBuilder] r => Sem (InfoTableBuilder ': r) a -> Sem r (BuilderState, InfoTable, a)
|
||||
runParserInfoTableBuilder :: (Members '[HighlightBuilder] r) => Sem (InfoTableBuilder ': r) a -> Sem r (BuilderState, InfoTable, a)
|
||||
runParserInfoTableBuilder m = do
|
||||
(builderState, x) <- runParserInfoTableBuilder' iniState m
|
||||
return (builderState, build builderState, x)
|
||||
|
@ -13,16 +13,16 @@ import Juvix.Compiler.Concrete.Data.ScopedName qualified as S
|
||||
import Juvix.Compiler.Concrete.Language
|
||||
import Juvix.Prelude
|
||||
|
||||
nsEntry :: forall ns. SingI ns => Lens' (NameSpaceEntryType ns) (S.Name' ())
|
||||
nsEntry :: forall ns. (SingI ns) => Lens' (NameSpaceEntryType ns) (S.Name' ())
|
||||
nsEntry = case sing :: SNameSpace ns of
|
||||
SNameSpaceModules -> moduleEntry
|
||||
SNameSpaceSymbols -> preSymbolName
|
||||
SNameSpaceFixities -> fixityEntry
|
||||
|
||||
mkModuleRef' :: SingI t => ModuleRef'' 'S.NotConcrete t -> ModuleRef' 'S.NotConcrete
|
||||
mkModuleRef' :: (SingI t) => ModuleRef'' 'S.NotConcrete t -> ModuleRef' 'S.NotConcrete
|
||||
mkModuleRef' m = ModuleRef' (sing :&: m)
|
||||
|
||||
scopeNameSpace :: forall (ns :: NameSpace). SingI ns => Lens' Scope (HashMap Symbol (SymbolInfo ns))
|
||||
scopeNameSpace :: forall (ns :: NameSpace). (SingI ns) => Lens' Scope (HashMap Symbol (SymbolInfo ns))
|
||||
scopeNameSpace = case sing :: SNameSpace ns of
|
||||
SNameSpaceSymbols -> scopeSymbols
|
||||
SNameSpaceModules -> scopeModuleSymbols
|
||||
|
@ -91,7 +91,7 @@ data AName = AName
|
||||
makeLenses ''Name'
|
||||
makeLenses ''AName
|
||||
|
||||
anameFromName :: HasLoc c => Name' c -> AName
|
||||
anameFromName :: (HasLoc c) => Name' c -> AName
|
||||
anameFromName n =
|
||||
AName
|
||||
{ _anameLoc = getLoc n,
|
||||
|
@ -67,7 +67,7 @@ unfoldApplication (Application l r) = go [r] l
|
||||
ExpressionApplication (Application l' r') -> go (r' : ac) l'
|
||||
e -> (e, ac)
|
||||
|
||||
groupStatements :: forall s. SingI s => [Statement s] -> [NonEmpty (Statement s)]
|
||||
groupStatements :: forall s. (SingI s) => [Statement s] -> [NonEmpty (Statement s)]
|
||||
groupStatements = \case
|
||||
[] -> []
|
||||
s : ss -> reverse . map NonEmpty.reverse . uncurry cons . foldl' aux (pure s, []) $ ss
|
||||
|
@ -8,7 +8,7 @@ import Juvix.Compiler.Concrete.Keywords
|
||||
import Juvix.Compiler.Concrete.Language
|
||||
import Juvix.Prelude
|
||||
|
||||
kw :: Members '[Reader Interval] r => Keyword -> Sem r KeywordRef
|
||||
kw :: (Members '[Reader Interval] r) => Keyword -> Sem r KeywordRef
|
||||
kw k = do
|
||||
loc <- ask
|
||||
return
|
||||
|
@ -1771,7 +1771,7 @@ instance Pretty ScopedIden where
|
||||
instance HasLoc ScopedIden where
|
||||
getLoc = getLoc . (^. scopedIdenName)
|
||||
|
||||
instance SingI s => HasLoc (InductiveParameters s) where
|
||||
instance (SingI s) => HasLoc (InductiveParameters s) where
|
||||
getLoc i = getLocSymbolType (i ^. inductiveParametersNames . _head1) <>? (getLocExpressionType <$> (i ^? inductiveParametersRhs . _Just . inductiveParametersType))
|
||||
|
||||
instance HasLoc (InductiveDef s) where
|
||||
|
@ -11,11 +11,11 @@ import Juvix.Compiler.Concrete.Print qualified as Print
|
||||
import Juvix.Data.PPOutput
|
||||
import Juvix.Prelude
|
||||
|
||||
ppOutDefault :: PrettyPrint c => c -> AnsiText
|
||||
ppOutDefault :: (PrettyPrint c) => c -> AnsiText
|
||||
ppOutDefault = Print.ppOutNoComments defaultOptions
|
||||
|
||||
ppOut :: (CanonicalProjection a Options, PrettyPrint c) => a -> c -> AnsiText
|
||||
ppOut = Print.ppOutNoComments
|
||||
|
||||
ppTrace :: PrettyPrint c => c -> Text
|
||||
ppTrace :: (PrettyPrint c) => c -> Text
|
||||
ppTrace = toAnsiText True . ppOut traceOptions
|
||||
|
@ -30,7 +30,7 @@ fromGenericOptions :: GenericOptions -> Options
|
||||
fromGenericOptions GenericOptions {..} =
|
||||
set optShowNameIds _showNameIds defaultOptions
|
||||
|
||||
inJudocBlock :: Members '[Reader Options] r => Sem r a -> Sem r a
|
||||
inJudocBlock :: (Members '[Reader Options] r) => Sem r a -> Sem r a
|
||||
inJudocBlock = local (set optInJudocBlock True)
|
||||
|
||||
instance CanonicalProjection GenericOptions Options where
|
||||
|
@ -30,10 +30,10 @@ import Juvix.Prelude hiding ((<+>), (<+?>), (<?+>), (?<>))
|
||||
import Juvix.Prelude.Pretty (annotate, pretty)
|
||||
import Juvix.Prelude.Pretty qualified as P
|
||||
|
||||
type PrettyPrinting a = forall r. Members '[ExactPrint, Reader Options] r => a -> Sem r ()
|
||||
type PrettyPrinting a = forall r. (Members '[ExactPrint, Reader Options] r) => a -> Sem r ()
|
||||
|
||||
class PrettyPrint a where
|
||||
ppCode :: Members '[ExactPrint, Reader Options] r => a -> Sem r ()
|
||||
ppCode :: (Members '[ExactPrint, Reader Options] r) => a -> Sem r ()
|
||||
|
||||
instance PrettyPrint Keyword where
|
||||
ppCode p = noLoc . annotate ann . pretty $ p
|
||||
@ -53,10 +53,10 @@ instance PrettyPrint KeywordRef where
|
||||
$ p
|
||||
)
|
||||
|
||||
docNoComments :: PrettyPrint c => Options -> c -> Doc Ann
|
||||
docNoComments :: (PrettyPrint c) => Options -> c -> Doc Ann
|
||||
docNoComments = docHelper Nothing
|
||||
|
||||
docHelper :: PrettyPrint c => Maybe FileComments -> Options -> c -> Doc Ann
|
||||
docHelper :: (PrettyPrint c) => Maybe FileComments -> Options -> c -> Doc Ann
|
||||
docHelper cs opts x =
|
||||
run
|
||||
. execExactPrint cs
|
||||
@ -64,7 +64,7 @@ docHelper cs opts x =
|
||||
. ppCode
|
||||
$ x
|
||||
|
||||
docNoLoc :: PrettyPrint c => Options -> c -> Doc Ann
|
||||
docNoLoc :: (PrettyPrint c) => Options -> c -> Doc Ann
|
||||
docNoLoc opts x = docHelper Nothing opts x
|
||||
|
||||
doc :: (PrettyPrint c, HasLoc c) => Options -> Comments -> c -> Doc Ann
|
||||
@ -86,62 +86,62 @@ ppModulePathType x = case sing :: SStage s of
|
||||
SModuleLocal -> annSDef x (ppCode x)
|
||||
SModuleTop -> annSDef x (ppCode x)
|
||||
|
||||
ppSymbolType :: forall s. SingI s => PrettyPrinting (SymbolType s)
|
||||
ppSymbolType :: forall s. (SingI s) => PrettyPrinting (SymbolType s)
|
||||
ppSymbolType = case sing :: SStage s of
|
||||
SParsed -> ppCode
|
||||
SScoped -> ppCode
|
||||
|
||||
ppIdentifierType :: forall s. SingI s => PrettyPrinting (IdentifierType s)
|
||||
ppIdentifierType :: forall s. (SingI s) => PrettyPrinting (IdentifierType s)
|
||||
ppIdentifierType = case sing :: SStage s of
|
||||
SParsed -> ppCode
|
||||
SScoped -> ppCode
|
||||
|
||||
ppModuleRefType :: forall s. SingI s => PrettyPrinting (ModuleRefType s)
|
||||
ppModuleRefType :: forall s. (SingI s) => PrettyPrinting (ModuleRefType s)
|
||||
ppModuleRefType = case sing :: SStage s of
|
||||
SParsed -> ppCode
|
||||
SScoped -> ppCode
|
||||
|
||||
ppImportType :: forall s. SingI s => PrettyPrinting (ImportType s)
|
||||
ppImportType :: forall s. (SingI s) => PrettyPrinting (ImportType s)
|
||||
ppImportType = case sing :: SStage s of
|
||||
SParsed -> ppCode
|
||||
SScoped -> ppCode
|
||||
|
||||
ppHoleType :: forall s. SingI s => PrettyPrinting (HoleType s)
|
||||
ppHoleType :: forall s. (SingI s) => PrettyPrinting (HoleType s)
|
||||
ppHoleType = case sing :: SStage s of
|
||||
SParsed -> ppCode
|
||||
SScoped -> ppCode
|
||||
|
||||
ppPatternAtomIdenType :: forall s. SingI s => PrettyPrinting (PatternAtomIdenType s)
|
||||
ppPatternAtomIdenType :: forall s. (SingI s) => PrettyPrinting (PatternAtomIdenType s)
|
||||
ppPatternAtomIdenType = case sing :: SStage s of
|
||||
SParsed -> ppCode
|
||||
SScoped -> ppCode
|
||||
|
||||
ppExpressionType :: forall s. SingI s => PrettyPrinting (ExpressionType s)
|
||||
ppExpressionType :: forall s. (SingI s) => PrettyPrinting (ExpressionType s)
|
||||
ppExpressionType = case sing :: SStage s of
|
||||
SParsed -> ppCode
|
||||
SScoped -> ppCode
|
||||
|
||||
ppExpressionAtomType :: forall s. SingI s => PrettyPrinting (ExpressionType s)
|
||||
ppExpressionAtomType :: forall s. (SingI s) => PrettyPrinting (ExpressionType s)
|
||||
ppExpressionAtomType = case sing :: SStage s of
|
||||
SParsed -> ppCodeAtom
|
||||
SScoped -> ppCodeAtom
|
||||
|
||||
ppPatternAtomType :: forall s. SingI s => PrettyPrinting (PatternAtomType s)
|
||||
ppPatternAtomType :: forall s. (SingI s) => PrettyPrinting (PatternAtomType s)
|
||||
ppPatternAtomType = case sing :: SStage s of
|
||||
SParsed -> ppCodeAtom
|
||||
SScoped -> ppCodeAtom
|
||||
|
||||
ppPatternParensType :: forall s. SingI s => PrettyPrinting (PatternParensType s)
|
||||
ppPatternParensType :: forall s. (SingI s) => PrettyPrinting (PatternParensType s)
|
||||
ppPatternParensType = case sing :: SStage s of
|
||||
SParsed -> ppCode
|
||||
SScoped -> ppCode
|
||||
|
||||
ppPatternAtType :: forall s. SingI s => PrettyPrinting (PatternAtType s)
|
||||
ppPatternAtType :: forall s. (SingI s) => PrettyPrinting (PatternAtType s)
|
||||
ppPatternAtType = case sing :: SStage s of
|
||||
SParsed -> ppCode
|
||||
SScoped -> ppCode
|
||||
|
||||
ppAnyStage :: forall k. (forall s. SingI s => PrettyPrint (k s)) => PrettyPrinting (AnyStage k)
|
||||
ppAnyStage :: forall k. (forall s. (SingI s) => PrettyPrint (k s)) => PrettyPrinting (AnyStage k)
|
||||
ppAnyStage (s :&: p) = case s of
|
||||
SParsed -> ppCode p
|
||||
SScoped -> ppCode p
|
||||
@ -158,7 +158,7 @@ instance PrettyPrint PatternBinding where
|
||||
p' = ppCode _patternBindingPattern
|
||||
n' <> ppCode Kw.kwAt <> p'
|
||||
|
||||
instance SingI s => PrettyPrint (ListPattern s) where
|
||||
instance (SingI s) => PrettyPrint (ListPattern s) where
|
||||
ppCode ListPattern {..} = do
|
||||
let l = ppCode _listpBracketL
|
||||
r = ppCode _listpBracketR
|
||||
@ -169,7 +169,7 @@ instance PrettyPrint Void where
|
||||
ppCode = absurd
|
||||
|
||||
instance PrettyPrint NameBlock where
|
||||
ppCode :: forall r. Members '[ExactPrint, Reader Options] r => NameBlock -> Sem r ()
|
||||
ppCode :: forall r. (Members '[ExactPrint, Reader Options] r) => NameBlock -> Sem r ()
|
||||
ppCode NameBlock {..} = do
|
||||
let delims = case _nameImplicit of
|
||||
Implicit -> braces
|
||||
@ -186,7 +186,7 @@ instance PrettyPrint NameSignature where
|
||||
| null _nameSignatureArgs = noLoc (pretty @Text "<empty name signature>")
|
||||
| otherwise = hsep . map ppCode $ _nameSignatureArgs
|
||||
|
||||
instance SingI s => PrettyPrint (PatternAtom s) where
|
||||
instance (SingI s) => PrettyPrint (PatternAtom s) where
|
||||
ppCode = \case
|
||||
PatternAtomIden n -> ppPatternAtomIdenType n
|
||||
PatternAtomWildcard w -> ppCode w
|
||||
@ -197,25 +197,25 @@ instance SingI s => PrettyPrint (PatternAtom s) where
|
||||
PatternAtomAt p -> ppPatternAtType p
|
||||
PatternAtomRecord p -> ppCode p
|
||||
|
||||
instance SingI s => PrettyPrint (PatternAtoms s) where
|
||||
instance (SingI s) => PrettyPrint (PatternAtoms s) where
|
||||
ppCode (PatternAtoms ps _) = hsep (ppCode <$> ps)
|
||||
|
||||
instance SingI s => PrettyPrint (ExpressionAtoms s) where
|
||||
instance (SingI s) => PrettyPrint (ExpressionAtoms s) where
|
||||
ppCode as = hsep (ppCode <$> as ^. expressionAtoms)
|
||||
|
||||
instance SingI s => PrettyPrint (Initializer s) where
|
||||
instance (SingI s) => PrettyPrint (Initializer s) where
|
||||
ppCode Initializer {..} = do
|
||||
let n = ppPatternParensType _initializerPattern
|
||||
e = ppExpressionType _initializerExpression
|
||||
n <+> ppCode _initializerAssignKw <+> e
|
||||
|
||||
instance SingI s => PrettyPrint (Range s) where
|
||||
instance (SingI s) => PrettyPrint (Range s) where
|
||||
ppCode Range {..} = do
|
||||
let n = ppPatternParensType _rangePattern
|
||||
e = ppExpressionType _rangeExpression
|
||||
n <+> ppCode _rangeInKw <+> e
|
||||
|
||||
instance SingI s => PrettyPrint (Iterator s) where
|
||||
instance (SingI s) => PrettyPrint (Iterator s) where
|
||||
ppCode Iterator {..} = do
|
||||
let n = ppIdentifierType _iteratorName
|
||||
is = ppCode <$> _iteratorInitializers
|
||||
@ -236,21 +236,21 @@ instance PrettyPrint FunctionInfo where
|
||||
ppCode = \case
|
||||
FunctionInfo f -> ppCode f
|
||||
|
||||
instance SingI s => PrettyPrint (List s) where
|
||||
instance (SingI s) => PrettyPrint (List s) where
|
||||
ppCode List {..} = do
|
||||
let l = ppCode _listBracketL
|
||||
r = ppCode _listBracketR
|
||||
e = hsepSemicolon (map ppExpressionType _listItems)
|
||||
l <> e <> r
|
||||
|
||||
instance SingI s => PrettyPrint (NamedArgument s) where
|
||||
instance (SingI s) => PrettyPrint (NamedArgument s) where
|
||||
ppCode NamedArgument {..} = do
|
||||
let s = ppCode _namedArgName
|
||||
kwassign = ppCode _namedArgAssignKw
|
||||
val = ppExpressionType _namedArgValue
|
||||
s <+> kwassign <+> val
|
||||
|
||||
instance SingI s => PrettyPrint (ArgumentBlock s) where
|
||||
instance (SingI s) => PrettyPrint (ArgumentBlock s) where
|
||||
ppCode ArgumentBlock {..} = do
|
||||
let args' = ppCode <$> _argBlockArgs
|
||||
(l, r) = case d of
|
||||
@ -260,15 +260,15 @@ instance SingI s => PrettyPrint (ArgumentBlock s) where
|
||||
where
|
||||
Irrelevant d = _argBlockDelims
|
||||
|
||||
instance SingI s => PrettyPrint (NamedApplication s) where
|
||||
instance (SingI s) => PrettyPrint (NamedApplication s) where
|
||||
-- ppCode :: Members '[ExactPrint, Reader Options] r => NamedApplication s -> Sem r ()
|
||||
ppCode = apeHelper
|
||||
|
||||
instance SingI s => PrettyPrint (RecordUpdateField s) where
|
||||
instance (SingI s) => PrettyPrint (RecordUpdateField s) where
|
||||
ppCode RecordUpdateField {..} =
|
||||
ppSymbolType _fieldUpdateName <+> ppCode _fieldUpdateAssignKw <+> ppExpressionType _fieldUpdateValue
|
||||
|
||||
instance SingI s => PrettyPrint (RecordUpdate s) where
|
||||
instance (SingI s) => PrettyPrint (RecordUpdate s) where
|
||||
ppCode RecordUpdate {..} = do
|
||||
let Irrelevant (l, r) = _recordUpdateDelims
|
||||
fields'
|
||||
@ -287,7 +287,7 @@ instance SingI s => PrettyPrint (RecordUpdate s) where
|
||||
<> fields'
|
||||
<> ppCode r
|
||||
|
||||
instance SingI s => PrettyPrint (ExpressionAtom s) where
|
||||
instance (SingI s) => PrettyPrint (ExpressionAtom s) where
|
||||
ppCode = \case
|
||||
AtomIdentifier n -> ppIdentifierType n
|
||||
AtomLambda l -> ppCode l
|
||||
@ -315,7 +315,7 @@ instance PrettyPrint Hole where
|
||||
let uid = h ^. holeId
|
||||
withNameIdSuffix uid (ppCode (h ^. holeKw))
|
||||
|
||||
withNameIdSuffix :: Members '[ExactPrint, Reader Options] r => S.NameId -> Sem r () -> Sem r ()
|
||||
withNameIdSuffix :: (Members '[ExactPrint, Reader Options] r) => S.NameId -> Sem r () -> Sem r ()
|
||||
withNameIdSuffix nid a = do
|
||||
showNameId <- asks (^. optShowNameIds)
|
||||
a
|
||||
@ -361,7 +361,7 @@ instance (SingI t, SingI s) => PrettyPrint (Module s t) where
|
||||
SModuleLocal -> ppCode _moduleKwEnd
|
||||
SModuleTop -> end
|
||||
|
||||
instance PrettyPrint a => PrettyPrint [a] where
|
||||
instance (PrettyPrint a) => PrettyPrint [a] where
|
||||
ppCode x = do
|
||||
let cs = map ppCode (toList x)
|
||||
encloseSep (ppCode @Text "[") (ppCode @Text "]") (ppCode @Text ", ") cs
|
||||
@ -380,8 +380,8 @@ instance PrettyPrint TopModulePath where
|
||||
ppCode TopModulePath {..} =
|
||||
dotted (map ppSymbolType (_modulePathDir ++ [_modulePathName]))
|
||||
|
||||
instance PrettyPrint n => PrettyPrint (S.Name' n) where
|
||||
ppCode :: forall r. Members '[ExactPrint, Reader Options] r => S.Name' n -> Sem r ()
|
||||
instance (PrettyPrint n) => PrettyPrint (S.Name' n) where
|
||||
ppCode :: forall r. (Members '[ExactPrint, Reader Options] r) => S.Name' n -> Sem r ()
|
||||
ppCode S.Name' {..} = do
|
||||
let nameConcrete' = region (C.annotateKind _nameKind) (ppCode _nameConcrete)
|
||||
annSRef (withNameIdSuffix _nameId nameConcrete')
|
||||
@ -395,12 +395,12 @@ instance PrettyPrint Name where
|
||||
NameQualified s -> ppCode s
|
||||
|
||||
instance PrettyPrint QualifiedName where
|
||||
ppCode :: Members '[ExactPrint, Reader Options] r => QualifiedName -> Sem r ()
|
||||
ppCode :: (Members '[ExactPrint, Reader Options] r) => QualifiedName -> Sem r ()
|
||||
ppCode QualifiedName {..} = do
|
||||
let symbols = _qualifiedPath ^. pathParts NonEmpty.|> _qualifiedSymbol
|
||||
dotted (ppSymbolType <$> symbols)
|
||||
|
||||
instance SingI t => PrettyPrint (ModuleRef'' 'S.NotConcrete t) where
|
||||
instance (SingI t) => PrettyPrint (ModuleRef'' 'S.NotConcrete t) where
|
||||
ppCode = ppCode @(ModuleRef' 'S.NotConcrete) . project
|
||||
|
||||
instance PrettyPrint (ModuleRef'' 'S.Concrete t) where
|
||||
@ -409,8 +409,8 @@ instance PrettyPrint (ModuleRef'' 'S.Concrete t) where
|
||||
instance PrettyPrint ScopedIden where
|
||||
ppCode = ppCode . (^. scopedIdenName)
|
||||
|
||||
instance SingI s => PrettyPrint (Import s) where
|
||||
ppCode :: forall r. Members '[ExactPrint, Reader Options] r => Import s -> Sem r ()
|
||||
instance (SingI s) => PrettyPrint (Import s) where
|
||||
ppCode :: forall r. (Members '[ExactPrint, Reader Options] r) => Import s -> Sem r ()
|
||||
ppCode i = do
|
||||
ppCode (i ^. importKw)
|
||||
<+> ppImportType (i ^. importModule)
|
||||
@ -421,7 +421,7 @@ instance SingI s => PrettyPrint (Import s) where
|
||||
Nothing -> Nothing
|
||||
Just as -> Just (ppCode Kw.kwAs <+> ppModulePathType as)
|
||||
|
||||
instance SingI s => PrettyPrint (AliasDef s) where
|
||||
instance (SingI s) => PrettyPrint (AliasDef s) where
|
||||
ppCode AliasDef {..} =
|
||||
ppCode _aliasDefSyntaxKw
|
||||
<+> ppCode _aliasDefAliasKw
|
||||
@ -429,7 +429,7 @@ instance SingI s => PrettyPrint (AliasDef s) where
|
||||
<+> ppCode Kw.kwAssign
|
||||
<+> ppIdentifierType _aliasDefAsName
|
||||
|
||||
instance SingI s => PrettyPrint (SyntaxDef s) where
|
||||
instance (SingI s) => PrettyPrint (SyntaxDef s) where
|
||||
ppCode = \case
|
||||
SyntaxFixity f -> ppCode f
|
||||
SyntaxOperator op -> ppCode op
|
||||
@ -444,25 +444,25 @@ ppLiteral = \case
|
||||
LitInteger n -> annotate AnnLiteralInteger (pretty n)
|
||||
LitString s -> ppStringLit s
|
||||
|
||||
instance SingI s => PrettyPrint (LambdaClause s) where
|
||||
instance (SingI s) => PrettyPrint (LambdaClause s) where
|
||||
ppCode LambdaClause {..} = do
|
||||
let lambdaParameters' = hsep (ppPatternAtom <$> _lambdaParameters)
|
||||
lambdaBody' = ppExpressionType _lambdaBody
|
||||
lambdaPipe' = ppCode <$> _lambdaPipe ^. unIrrelevant
|
||||
lambdaPipe' <?+> lambdaParameters' <+> ppCode _lambdaAssignKw <> oneLineOrNext lambdaBody'
|
||||
|
||||
instance SingI s => PrettyPrint (LetStatement s) where
|
||||
instance (SingI s) => PrettyPrint (LetStatement s) where
|
||||
ppCode = \case
|
||||
LetFunctionDef f -> ppCode f
|
||||
LetAliasDef f -> ppCode f
|
||||
|
||||
instance SingI s => PrettyPrint (Let s) where
|
||||
instance (SingI s) => PrettyPrint (Let s) where
|
||||
ppCode Let {..} = do
|
||||
let letFunDefs' = blockIndent (ppBlock _letFunDefs)
|
||||
letExpression' = ppExpressionType _letExpression
|
||||
ppCode _letKw <> letFunDefs' <> ppCode _letInKw <+> letExpression'
|
||||
|
||||
instance SingI s => PrettyPrint (Case s) where
|
||||
instance (SingI s) => PrettyPrint (Case s) where
|
||||
ppCode Case {..} = do
|
||||
let exp' = ppExpressionType _caseExpression
|
||||
branches' = indent . vsepHard $ fmap ppCode _caseBranches
|
||||
@ -493,11 +493,11 @@ annDef nm = case sing :: SStage s of
|
||||
SScoped -> annSDef nm
|
||||
SParsed -> id
|
||||
|
||||
annSDef :: Members '[ExactPrint] r => S.Name' n -> Sem r () -> Sem r ()
|
||||
annSDef :: (Members '[ExactPrint] r) => S.Name' n -> Sem r () -> Sem r ()
|
||||
annSDef S.Name' {..} = annotated (AnnDef (_nameDefinedIn ^. S.absTopModulePath) _nameId)
|
||||
|
||||
instance SingI s => PrettyPrint (FunctionParameters s) where
|
||||
ppCode :: forall r. Members '[ExactPrint, Reader Options] r => FunctionParameters s -> Sem r ()
|
||||
instance (SingI s) => PrettyPrint (FunctionParameters s) where
|
||||
ppCode :: forall r. (Members '[ExactPrint, Reader Options] r) => FunctionParameters s -> Sem r ()
|
||||
ppCode FunctionParameters {..} = do
|
||||
case _paramNames of
|
||||
[] -> ppLeftExpression' funFixity _paramType
|
||||
@ -512,12 +512,12 @@ instance SingI s => PrettyPrint (FunctionParameters s) where
|
||||
SParsed -> ppLeftExpression
|
||||
SScoped -> ppLeftExpression
|
||||
|
||||
instance SingI s => PrettyPrint (FunctionParameter s) where
|
||||
instance (SingI s) => PrettyPrint (FunctionParameter s) where
|
||||
ppCode = \case
|
||||
FunctionParameterName n -> annDef n (ppSymbolType n)
|
||||
FunctionParameterWildcard w -> ppCode w
|
||||
|
||||
instance SingI s => PrettyPrint (Function s) where
|
||||
instance (SingI s) => PrettyPrint (Function s) where
|
||||
ppCode :: forall r. (Members '[ExactPrint, Reader Options] r) => Function s -> Sem r ()
|
||||
ppCode a = case sing :: SStage s of
|
||||
SParsed -> helper a
|
||||
@ -559,7 +559,7 @@ ppLRExpression associates fixlr e =
|
||||
(atomParens associates (atomicity e) fixlr)
|
||||
(ppCode e)
|
||||
|
||||
instance SingI s => PrettyPrint (CaseBranch s) where
|
||||
instance (SingI s) => PrettyPrint (CaseBranch s) where
|
||||
ppCode CaseBranch {..} = do
|
||||
let pat' = ppPatternParensType _caseBranchPattern
|
||||
e' = ppExpressionType _caseBranchExpression
|
||||
@ -568,7 +568,7 @@ instance SingI s => PrettyPrint (CaseBranch s) where
|
||||
ppBlock :: (PrettyPrint a, Members '[Reader Options, ExactPrint] r, Traversable t) => t a -> Sem r ()
|
||||
ppBlock items = vsep (sepEndSemicolon (fmap ppCode items))
|
||||
|
||||
instance SingI s => PrettyPrint (Lambda s) where
|
||||
instance (SingI s) => PrettyPrint (Lambda s) where
|
||||
ppCode Lambda {..} = do
|
||||
let lambdaKw' = ppCode _lambdaKw
|
||||
braces' = uncurry enclose (over both ppCode (_lambdaBraces ^. unIrrelevant))
|
||||
@ -584,7 +584,7 @@ instance PrettyPrint Precedence where
|
||||
PrecApp -> noLoc (pretty ("ω" :: Text))
|
||||
PrecUpdate -> noLoc (pretty ("ω₁" :: Text))
|
||||
|
||||
instance SingI s => PrettyPrint (FixitySyntaxDef s) where
|
||||
instance (SingI s) => PrettyPrint (FixitySyntaxDef s) where
|
||||
ppCode FixitySyntaxDef {..} = do
|
||||
let sym' = ppSymbolType _fixitySymbol
|
||||
let txt = pretty (_fixityInfo ^. withLocParam . withSourceText)
|
||||
@ -653,24 +653,24 @@ instance PrettyPrint (WithSource Pragmas) where
|
||||
instance PrettyPrint (WithSource IteratorAttribs) where
|
||||
ppCode = braces . noLoc . pretty . (^. withSourceText)
|
||||
|
||||
ppJudocStart :: Members '[ExactPrint, Reader Options] r => Sem r (Maybe ())
|
||||
ppJudocStart :: (Members '[ExactPrint, Reader Options] r) => Sem r (Maybe ())
|
||||
ppJudocStart = do
|
||||
inBlock <- asks (^. optInJudocBlock)
|
||||
if
|
||||
| inBlock -> return Nothing
|
||||
| otherwise -> ppCode Kw.delimJudocStart $> Just ()
|
||||
|
||||
instance SingI s => PrettyPrint (Example s) where
|
||||
instance (SingI s) => PrettyPrint (Example s) where
|
||||
ppCode e =
|
||||
ppJudocStart
|
||||
<??+> ppCode Kw.delimJudocExample
|
||||
<+> ppExpressionType (e ^. exampleExpression)
|
||||
<> semicolon
|
||||
|
||||
instance PrettyPrint a => PrettyPrint (WithLoc a) where
|
||||
instance (PrettyPrint a) => PrettyPrint (WithLoc a) where
|
||||
ppCode a = morphemeM (getLoc a) (ppCode (a ^. withLocParam))
|
||||
|
||||
instance SingI s => PrettyPrint (JudocAtom s) where
|
||||
instance (SingI s) => PrettyPrint (JudocAtom s) where
|
||||
ppCode :: forall r. (Members '[Reader Options, ExactPrint] r) => JudocAtom s -> Sem r ()
|
||||
ppCode = \case
|
||||
JudocExpression e -> goExpression e
|
||||
@ -681,15 +681,15 @@ instance SingI s => PrettyPrint (JudocAtom s) where
|
||||
semiDelim :: Sem r () -> Sem r ()
|
||||
semiDelim = enclose1 (annotated AnnJudoc (noLoc (";" :: Doc Ann)))
|
||||
|
||||
instance SingI s => PrettyPrint (JudocLine s) where
|
||||
ppCode :: forall r. Members '[ExactPrint, Reader Options] r => JudocLine s -> Sem r ()
|
||||
instance (SingI s) => PrettyPrint (JudocLine s) where
|
||||
ppCode :: forall r. (Members '[ExactPrint, Reader Options] r) => JudocLine s -> Sem r ()
|
||||
ppCode (JudocLine deli atoms) = do
|
||||
let start' :: Maybe (Sem r ()) = ppCode <$> deli
|
||||
atoms' = mapM_ ppCode atoms
|
||||
start' <?+> atoms'
|
||||
|
||||
instance SingI s => PrettyPrint (Judoc s) where
|
||||
ppCode :: forall r. Members '[ExactPrint, Reader Options] r => Judoc s -> Sem r ()
|
||||
instance (SingI s) => PrettyPrint (Judoc s) where
|
||||
ppCode :: forall r. (Members '[ExactPrint, Reader Options] r) => Judoc s -> Sem r ()
|
||||
ppCode (Judoc groups) = ppGroups groups <> line
|
||||
where
|
||||
ppGroups :: NonEmpty (JudocGroup s) -> Sem r ()
|
||||
@ -704,15 +704,15 @@ instance SingI s => PrettyPrint (Judoc s) where
|
||||
(JudocGroupLines {}, JudocGroupLines {}) -> ppCode Kw.delimJudocStart <> line
|
||||
_ -> return ()
|
||||
|
||||
instance SingI s => PrettyPrint (JudocBlockParagraph s) where
|
||||
instance (SingI s) => PrettyPrint (JudocBlockParagraph s) where
|
||||
ppCode p = do
|
||||
let start' = ppCode (p ^. judocBlockParagraphStart)
|
||||
contents' = inJudocBlock (vsep2 (ppCode <$> p ^. judocBlockParagraphBlocks))
|
||||
endpar' = ppCode (p ^. judocBlockParagraphEnd)
|
||||
start' <+> contents' <+> endpar'
|
||||
|
||||
instance SingI s => PrettyPrint (JudocGroup s) where
|
||||
ppCode :: forall r. Members '[ExactPrint, Reader Options] r => JudocGroup s -> Sem r ()
|
||||
instance (SingI s) => PrettyPrint (JudocGroup s) where
|
||||
ppCode :: forall r. (Members '[ExactPrint, Reader Options] r) => JudocGroup s -> Sem r ()
|
||||
ppCode = \case
|
||||
JudocGroupLines l -> goLines l
|
||||
JudocGroupBlock l -> ppCode l
|
||||
@ -722,13 +722,13 @@ instance SingI s => PrettyPrint (JudocGroup s) where
|
||||
blockSep :: Sem r ()
|
||||
blockSep = hardline >> ppJudocStart >> hardline
|
||||
|
||||
instance SingI s => PrettyPrint (JudocBlock s) where
|
||||
instance (SingI s) => PrettyPrint (JudocBlock s) where
|
||||
ppCode = \case
|
||||
JudocLines l -> vsep (ppCode <$> l)
|
||||
JudocExample e -> ppCode e
|
||||
|
||||
instance SingI s => PrettyPrint (AxiomDef s) where
|
||||
ppCode :: forall r. Members '[ExactPrint, Reader Options] r => AxiomDef s -> Sem r ()
|
||||
instance (SingI s) => PrettyPrint (AxiomDef s) where
|
||||
ppCode :: forall r. (Members '[ExactPrint, Reader Options] r) => AxiomDef s -> Sem r ()
|
||||
ppCode AxiomDef {..} = do
|
||||
let axiomName' = annDef _axiomName (ppSymbolType _axiomName)
|
||||
builtin' :: Maybe (Sem r ()) = (<> line) . ppCode <$> _axiomBuiltin
|
||||
@ -751,34 +751,34 @@ instance PrettyPrint BuiltinFunction where
|
||||
instance PrettyPrint BuiltinAxiom where
|
||||
ppCode i = ppCode Kw.kwBuiltin <+> keywordText (P.prettyText i)
|
||||
|
||||
instance SingI s => PrettyPrint (NewFunctionClause s) where
|
||||
ppCode :: forall r. Members '[ExactPrint, Reader Options] r => NewFunctionClause s -> Sem r ()
|
||||
instance (SingI s) => PrettyPrint (NewFunctionClause s) where
|
||||
ppCode :: forall r. (Members '[ExactPrint, Reader Options] r) => NewFunctionClause s -> Sem r ()
|
||||
ppCode NewFunctionClause {..} = do
|
||||
let pats' = hsep (ppPatternAtomType <$> _clausenPatterns)
|
||||
e' = ppExpressionType _clausenBody
|
||||
ppCode _clausenPipeKw <+> pats' <+> ppCode _clausenAssignKw <> oneLineOrNext e'
|
||||
|
||||
instance SingI s => PrettyPrint (Argument s) where
|
||||
ppCode :: Members '[ExactPrint, Reader Options] r => Argument s -> Sem r ()
|
||||
instance (SingI s) => PrettyPrint (Argument s) where
|
||||
ppCode :: (Members '[ExactPrint, Reader Options] r) => Argument s -> Sem r ()
|
||||
ppCode = \case
|
||||
ArgumentSymbol s -> ppSymbolType s
|
||||
ArgumentWildcard w -> ppCode w
|
||||
|
||||
instance SingI s => PrettyPrint (SigArgRhs s) where
|
||||
instance (SingI s) => PrettyPrint (SigArgRhs s) where
|
||||
ppCode :: (Members '[ExactPrint, Reader Options] r) => SigArgRhs s -> Sem r ()
|
||||
ppCode SigArgRhs {..} =
|
||||
ppCode _sigArgColon <+> ppExpressionType _sigArgType
|
||||
|
||||
instance SingI s => PrettyPrint (SigArg s) where
|
||||
ppCode :: Members '[ExactPrint, Reader Options] r => SigArg s -> Sem r ()
|
||||
instance (SingI s) => PrettyPrint (SigArg s) where
|
||||
ppCode :: (Members '[ExactPrint, Reader Options] r) => SigArg s -> Sem r ()
|
||||
ppCode SigArg {..} = do
|
||||
let Irrelevant (l, r) = _sigArgDelims
|
||||
names' = hsep (fmap ppCode _sigArgNames)
|
||||
rhs = ppCode <$> _sigArgRhs
|
||||
ppCode l <> names' <+?> rhs <> ppCode r
|
||||
|
||||
instance SingI s => PrettyPrint (FunctionDef s) where
|
||||
ppCode :: forall r. Members '[ExactPrint, Reader Options] r => FunctionDef s -> Sem r ()
|
||||
instance (SingI s) => PrettyPrint (FunctionDef s) where
|
||||
ppCode :: forall r. (Members '[ExactPrint, Reader Options] r) => FunctionDef s -> Sem r ()
|
||||
ppCode FunctionDef {..} = do
|
||||
let termin' :: Maybe (Sem r ()) = (<> line) . ppCode <$> _signTerminating
|
||||
doc' :: Maybe (Sem r ()) = ppCode <$> _signDoc
|
||||
@ -803,21 +803,21 @@ instance SingI s => PrettyPrint (FunctionDef s) where
|
||||
instance PrettyPrint Wildcard where
|
||||
ppCode w = morpheme (getLoc w) C.kwWildcard
|
||||
|
||||
instance SingI s => PrettyPrint (FieldPun s) where
|
||||
instance (SingI s) => PrettyPrint (FieldPun s) where
|
||||
ppCode = ppSymbolType . (^. fieldPunField)
|
||||
|
||||
instance SingI s => PrettyPrint (RecordPatternAssign s) where
|
||||
instance (SingI s) => PrettyPrint (RecordPatternAssign s) where
|
||||
ppCode a = do
|
||||
ppCode (a ^. recordPatternAssignField)
|
||||
<+> ppCode (a ^. recordPatternAssignKw)
|
||||
<+> ppPatternParensType (a ^. recordPatternAssignPattern)
|
||||
|
||||
instance SingI s => PrettyPrint (RecordPatternItem s) where
|
||||
instance (SingI s) => PrettyPrint (RecordPatternItem s) where
|
||||
ppCode = \case
|
||||
RecordPatternItemFieldPun f -> ppCode f
|
||||
RecordPatternItemAssign f -> ppCode f
|
||||
|
||||
instance SingI s => PrettyPrint (RecordPattern s) where
|
||||
instance (SingI s) => PrettyPrint (RecordPattern s) where
|
||||
ppCode r = do
|
||||
let c = ppIdentifierType (r ^. recordPatternConstructor)
|
||||
items = sepSemicolon (map ppCode (r ^. recordPatternItems))
|
||||
@ -851,35 +851,35 @@ instance PrettyPrint PatternArg where
|
||||
instance PrettyPrint Text where
|
||||
ppCode = noLoc . pretty
|
||||
|
||||
ppUnkindedSymbol :: Members '[Reader Options, ExactPrint] r => WithLoc Text -> Sem r ()
|
||||
ppUnkindedSymbol :: (Members '[Reader Options, ExactPrint] r) => WithLoc Text -> Sem r ()
|
||||
ppUnkindedSymbol = region (annotate AnnUnkindedSym) . ppCode
|
||||
|
||||
instance SingI s => PrettyPrint (HidingItem s) where
|
||||
instance (SingI s) => PrettyPrint (HidingItem s) where
|
||||
ppCode h = do
|
||||
let sym = ppSymbolType (h ^. hidingSymbol)
|
||||
kwmodule = ppCode <$> (h ^. hidingModuleKw)
|
||||
kwmodule <?+> sym
|
||||
|
||||
instance SingI s => PrettyPrint (HidingList s) where
|
||||
instance (SingI s) => PrettyPrint (HidingList s) where
|
||||
ppCode HidingList {..} = do
|
||||
let (openb, closeb) = _hidingBraces ^. unIrrelevant
|
||||
items' = sequenceWith (semicolon <> space) (ppCode <$> _hidingList)
|
||||
ppCode _hidingKw <+> ppCode openb <> items' <> ppCode closeb
|
||||
|
||||
instance SingI s => PrettyPrint (UsingList s) where
|
||||
instance (SingI s) => PrettyPrint (UsingList s) where
|
||||
ppCode UsingList {..} = do
|
||||
let (openb, closeb) = _usingBraces ^. unIrrelevant
|
||||
items' = sequenceWith (semicolon <> space) (ppCode <$> _usingList)
|
||||
ppCode _usingKw <+> ppCode openb <> items' <> ppCode closeb
|
||||
|
||||
instance SingI s => PrettyPrint (UsingHiding s) where
|
||||
ppCode :: forall r. Members '[ExactPrint, Reader Options] r => UsingHiding s -> Sem r ()
|
||||
instance (SingI s) => PrettyPrint (UsingHiding s) where
|
||||
ppCode :: forall r. (Members '[ExactPrint, Reader Options] r) => UsingHiding s -> Sem r ()
|
||||
ppCode = \case
|
||||
Using u -> ppCode u
|
||||
Hiding h -> ppCode h
|
||||
|
||||
instance SingI s => PrettyPrint (UsingItem s) where
|
||||
ppCode :: forall r. Members '[ExactPrint, Reader Options] r => UsingItem s -> Sem r ()
|
||||
instance (SingI s) => PrettyPrint (UsingItem s) where
|
||||
ppCode :: forall r. (Members '[ExactPrint, Reader Options] r) => UsingItem s -> Sem r ()
|
||||
ppCode ui = do
|
||||
let kwAs' :: Maybe (Sem r ()) = ppCode <$> ui ^. usingAsKw . unIrrelevant
|
||||
alias' = ppSymbolType <$> ui ^. usingAs
|
||||
@ -898,8 +898,8 @@ instance PrettyPrint (ModuleRef' 'S.NotConcrete) where
|
||||
instance PrettyPrint ModuleRef where
|
||||
ppCode (ModuleRef' (_ :&: ModuleRef'' {..})) = ppCode _moduleRefName
|
||||
|
||||
instance SingI s => PrettyPrint (OpenModule s) where
|
||||
ppCode :: forall r. Members '[ExactPrint, Reader Options] r => OpenModule s -> Sem r ()
|
||||
instance (SingI s) => PrettyPrint (OpenModule s) where
|
||||
ppCode :: forall r. (Members '[ExactPrint, Reader Options] r) => OpenModule s -> Sem r ()
|
||||
ppCode OpenModule {..} = do
|
||||
let name' = ppModuleRefType _openModuleName
|
||||
usingHiding' = ppCode <$> _openUsingHiding
|
||||
@ -926,7 +926,7 @@ ppCodeAtom c = do
|
||||
let p' = ppCode c
|
||||
if isAtomic c then p' else parens p'
|
||||
|
||||
ppPatternAtom :: forall s. SingI s => PrettyPrinting (PatternAtomType s)
|
||||
ppPatternAtom :: forall s. (SingI s) => PrettyPrinting (PatternAtomType s)
|
||||
ppPatternAtom = case sing :: SStage s of
|
||||
SParsed -> ppCodeAtom
|
||||
SScoped -> \pat ->
|
||||
@ -934,32 +934,32 @@ ppPatternAtom = case sing :: SStage s of
|
||||
PatternVariable s | s ^. S.nameVerbatim == "=" -> parens (ppCodeAtom pat)
|
||||
_ -> ppCodeAtom pat
|
||||
|
||||
instance SingI s => PrettyPrint (InductiveParametersRhs s) where
|
||||
instance (SingI s) => PrettyPrint (InductiveParametersRhs s) where
|
||||
ppCode InductiveParametersRhs {..} =
|
||||
ppCode _inductiveParametersColon <+> ppExpressionType _inductiveParametersType
|
||||
|
||||
instance SingI s => PrettyPrint (InductiveParameters s) where
|
||||
instance (SingI s) => PrettyPrint (InductiveParameters s) where
|
||||
ppCode InductiveParameters {..} = do
|
||||
let names' = fmap (\nm -> annDef nm (ppSymbolType nm)) _inductiveParametersNames
|
||||
case _inductiveParametersRhs of
|
||||
Just rhs -> parens (hsep names' <+> ppCode rhs)
|
||||
Nothing -> hsep names'
|
||||
|
||||
instance SingI s => PrettyPrint (NonEmpty (InductiveParameters s)) where
|
||||
instance (SingI s) => PrettyPrint (NonEmpty (InductiveParameters s)) where
|
||||
ppCode = hsep . fmap ppCode
|
||||
|
||||
instance PrettyPrint a => PrettyPrint (Irrelevant a) where
|
||||
instance (PrettyPrint a) => PrettyPrint (Irrelevant a) where
|
||||
ppCode (Irrelevant a) = ppCode a
|
||||
|
||||
instance SingI s => PrettyPrint (RhsGadt s) where
|
||||
instance (SingI s) => PrettyPrint (RhsGadt s) where
|
||||
ppCode RhsGadt {..} =
|
||||
ppCode _rhsGadtColon <+> ppExpressionType _rhsGadtType
|
||||
|
||||
instance SingI s => PrettyPrint (RecordField s) where
|
||||
instance (SingI s) => PrettyPrint (RecordField s) where
|
||||
ppCode RecordField {..} =
|
||||
ppSymbolType _fieldName <+> ppCode _fieldColon <+> ppExpressionType _fieldType
|
||||
|
||||
instance SingI s => PrettyPrint (RhsRecord s) where
|
||||
instance (SingI s) => PrettyPrint (RhsRecord s) where
|
||||
ppCode RhsRecord {..} = do
|
||||
let Irrelevant (l, r) = _rhsRecordDelim
|
||||
fields'
|
||||
@ -974,18 +974,18 @@ instance SingI s => PrettyPrint (RhsRecord s) where
|
||||
<> line
|
||||
ppCode l <> fields' <> ppCode r
|
||||
|
||||
instance SingI s => PrettyPrint (RhsAdt s) where
|
||||
instance (SingI s) => PrettyPrint (RhsAdt s) where
|
||||
ppCode = align . sep . fmap ppExpressionAtomType . (^. rhsAdtArguments)
|
||||
|
||||
instance SingI s => PrettyPrint (ConstructorRhs s) where
|
||||
ppCode :: Members '[ExactPrint, Reader Options] r => ConstructorRhs s -> Sem r ()
|
||||
instance (SingI s) => PrettyPrint (ConstructorRhs s) where
|
||||
ppCode :: (Members '[ExactPrint, Reader Options] r) => ConstructorRhs s -> Sem r ()
|
||||
ppCode = \case
|
||||
ConstructorRhsGadt r -> ppCode r
|
||||
ConstructorRhsRecord r -> ppCode r
|
||||
ConstructorRhsAdt r -> ppCode r
|
||||
|
||||
instance SingI s => PrettyPrint (ConstructorDef s) where
|
||||
ppCode :: forall r. Members '[ExactPrint, Reader Options] r => ConstructorDef s -> Sem r ()
|
||||
instance (SingI s) => PrettyPrint (ConstructorDef s) where
|
||||
ppCode :: forall r. (Members '[ExactPrint, Reader Options] r) => ConstructorDef s -> Sem r ()
|
||||
ppCode ConstructorDef {..} = do
|
||||
let constructorName' = annDef _constructorName (ppSymbolType _constructorName)
|
||||
constructorRhs' = constructorRhsHelper _constructorRhs
|
||||
@ -1009,7 +1009,7 @@ instance SingI s => PrettyPrint (ConstructorDef s) where
|
||||
Just p -> ppCode p
|
||||
Nothing -> ppCode Kw.kwPipe
|
||||
|
||||
ppInductiveSignature :: SingI s => PrettyPrinting (InductiveDef s)
|
||||
ppInductiveSignature :: (SingI s) => PrettyPrinting (InductiveDef s)
|
||||
ppInductiveSignature InductiveDef {..} = do
|
||||
let builtin' = (<> line) . ppCode <$> _inductiveBuiltin
|
||||
name' = annDef _inductiveName (ppSymbolType _inductiveName)
|
||||
@ -1027,8 +1027,8 @@ ppInductiveSignature InductiveDef {..} = do
|
||||
<+?> params'
|
||||
<+?> ty'
|
||||
|
||||
instance SingI s => PrettyPrint (InductiveDef s) where
|
||||
ppCode :: forall r. Members '[ExactPrint, Reader Options] r => InductiveDef s -> Sem r ()
|
||||
instance (SingI s) => PrettyPrint (InductiveDef s) where
|
||||
ppCode :: forall r. (Members '[ExactPrint, Reader Options] r) => InductiveDef s -> Sem r ()
|
||||
ppCode d@InductiveDef {..} = do
|
||||
let doc' = ppCode <$> _inductiveDoc
|
||||
pragmas' = ppCode <$> _inductivePragmas
|
||||
@ -1044,7 +1044,7 @@ instance SingI s => PrettyPrint (InductiveDef s) where
|
||||
ppConstructorBlock :: NonEmpty (ConstructorDef s) -> Sem r ()
|
||||
ppConstructorBlock cs = vsep (ppCode <$> cs)
|
||||
|
||||
instance SingI s => PrettyPrint (ProjectionDef s) where
|
||||
instance (SingI s) => PrettyPrint (ProjectionDef s) where
|
||||
ppCode ProjectionDef {..} =
|
||||
do
|
||||
ppSymbolType _projectionField
|
||||
@ -1053,7 +1053,7 @@ instance SingI s => PrettyPrint (ProjectionDef s) where
|
||||
<+> noLoc "for"
|
||||
<+> ppCode _projectionConstructor
|
||||
|
||||
instance SingI s => PrettyPrint (Statement s) where
|
||||
instance (SingI s) => PrettyPrint (Statement s) where
|
||||
ppCode = \case
|
||||
StatementSyntax s -> ppCode s
|
||||
StatementFunctionDef f -> ppCode f
|
||||
@ -1108,11 +1108,11 @@ instance PrettyPrint ModuleSymbolEntry where
|
||||
let k = getNameKind ent
|
||||
in (pretty (nameKindText k))
|
||||
|
||||
header :: Members '[ExactPrint] r => Text -> Sem r ()
|
||||
header :: (Members '[ExactPrint] r) => Text -> Sem r ()
|
||||
header txt = annotated AnnImportant (noLoc (pretty (txt <> "\n")))
|
||||
|
||||
instance PrettyPrint ScoperState where
|
||||
ppCode :: Members '[ExactPrint, Reader Options] r => ScoperState -> Sem r ()
|
||||
ppCode :: (Members '[ExactPrint, Reader Options] r) => ScoperState -> Sem r ()
|
||||
ppCode s =
|
||||
do
|
||||
header "scoperModules"
|
||||
|
@ -63,7 +63,7 @@ iniResolverState =
|
||||
_resolverFiles = mempty
|
||||
}
|
||||
|
||||
withEnvRoot :: Members '[Reader ResolverEnv] r => Path Abs Dir -> Sem r a -> Sem r a
|
||||
withEnvRoot :: (Members '[Reader ResolverEnv] r) => Path Abs Dir -> Sem r a -> Sem r a
|
||||
withEnvRoot root' = local (set envRoot root')
|
||||
|
||||
mkPackageInfo ::
|
||||
@ -103,7 +103,7 @@ dependencyCached d = do
|
||||
withPathFile :: (Members '[PathResolver] r) => TopModulePath -> (Either PathResolverError (Path Abs File) -> Sem r a) -> Sem r a
|
||||
withPathFile m f = withPath m (f . mapRight (uncurry (<//>)))
|
||||
|
||||
getDependencyPath :: Members '[Reader ResolverEnv, Files] r => Dependency -> Sem r (Path Abs Dir)
|
||||
getDependencyPath :: (Members '[Reader ResolverEnv, Files] r) => Dependency -> Sem r (Path Abs Dir)
|
||||
getDependencyPath (Dependency p) = do
|
||||
r <- asks (^. envRoot)
|
||||
canonicalDir r p
|
||||
@ -176,7 +176,7 @@ resolvePath' mp = do
|
||||
}
|
||||
)
|
||||
|
||||
expectedPath' :: Members '[Reader ResolverEnv] r => Path Abs File -> TopModulePath -> Sem r (Maybe (Path Abs File))
|
||||
expectedPath' :: (Members '[Reader ResolverEnv] r) => Path Abs File -> TopModulePath -> Sem r (Maybe (Path Abs File))
|
||||
expectedPath' actualPath m = do
|
||||
root <- asks (^. envRoot)
|
||||
msingle <- asks (^. envSingleFile)
|
||||
|
@ -118,24 +118,24 @@ scopeCheckExpression tab as = mapError (JuvixError @ScoperError) $ do
|
||||
|
||||
scopeCheckImport ::
|
||||
forall r.
|
||||
Members '[Error JuvixError, InfoTableBuilder, NameIdGen, State Scope, Reader ScopeParameters, State ScoperState] r =>
|
||||
(Members '[Error JuvixError, InfoTableBuilder, NameIdGen, State Scope, Reader ScopeParameters, State ScoperState] r) =>
|
||||
Import 'Parsed ->
|
||||
Sem r (Import 'Scoped)
|
||||
scopeCheckImport = mapError (JuvixError @ScoperError) . checkImport
|
||||
|
||||
scopeCheckOpenModule ::
|
||||
forall r.
|
||||
Members '[Error JuvixError, InfoTableBuilder, NameIdGen, State Scope, Reader ScopeParameters, State ScoperState] r =>
|
||||
(Members '[Error JuvixError, InfoTableBuilder, NameIdGen, State Scope, Reader ScopeParameters, State ScoperState] r) =>
|
||||
OpenModule 'Parsed ->
|
||||
Sem r (OpenModule 'Scoped)
|
||||
scopeCheckOpenModule = mapError (JuvixError @ScoperError) . checkOpenModule
|
||||
|
||||
freshVariable :: Members '[NameIdGen, State ScoperSyntax, State Scope, State ScoperState] r => Symbol -> Sem r S.Symbol
|
||||
freshVariable :: (Members '[NameIdGen, State ScoperSyntax, State Scope, State ScoperState] r) => Symbol -> Sem r S.Symbol
|
||||
freshVariable = freshSymbol KNameLocal
|
||||
|
||||
checkProjectionDef ::
|
||||
forall r.
|
||||
Members '[Error ScoperError, InfoTableBuilder, Reader BindingStrategy, State Scope, State ScoperState, NameIdGen, State ScoperSyntax] r =>
|
||||
(Members '[Error ScoperError, InfoTableBuilder, Reader BindingStrategy, State Scope, State ScoperState, NameIdGen, State ScoperSyntax] r) =>
|
||||
ProjectionDef 'Parsed ->
|
||||
Sem r (ProjectionDef 'Scoped)
|
||||
checkProjectionDef p = do
|
||||
@ -149,7 +149,7 @@ checkProjectionDef p = do
|
||||
|
||||
freshSymbol ::
|
||||
forall r.
|
||||
Members '[State Scope, State ScoperState, NameIdGen, State ScoperSyntax] r =>
|
||||
(Members '[State Scope, State ScoperState, NameIdGen, State ScoperSyntax] r) =>
|
||||
NameKind ->
|
||||
Symbol ->
|
||||
Sem r S.Symbol
|
||||
@ -263,7 +263,7 @@ reserveSymbolOf k nameSig s = do
|
||||
|
||||
getReservedDefinitionSymbol ::
|
||||
forall r.
|
||||
Members '[Error ScoperError, NameIdGen, State ScoperSyntax, State Scope, InfoTableBuilder, State ScoperState, Reader BindingStrategy] r =>
|
||||
(Members '[Error ScoperError, NameIdGen, State ScoperSyntax, State Scope, InfoTableBuilder, State ScoperState, Reader BindingStrategy] r) =>
|
||||
Symbol ->
|
||||
Sem r S.Symbol
|
||||
getReservedDefinitionSymbol s = do
|
||||
@ -277,75 +277,75 @@ ignoreSyntax = evalState emptyScoperSyntax
|
||||
|
||||
-- | Variables are assumed to never be infix operators
|
||||
bindVariableSymbol ::
|
||||
Members '[Error ScoperError, NameIdGen, State Scope, InfoTableBuilder, State ScoperState] r =>
|
||||
(Members '[Error ScoperError, NameIdGen, State Scope, InfoTableBuilder, State ScoperState] r) =>
|
||||
Symbol ->
|
||||
Sem r S.Symbol
|
||||
bindVariableSymbol = localBindings . ignoreSyntax . reserveSymbolOf SKNameLocal Nothing
|
||||
|
||||
reserveInductiveSymbol ::
|
||||
Members '[Error ScoperError, NameIdGen, State ScoperSyntax, State Scope, State ScoperState, Reader BindingStrategy, InfoTableBuilder] r =>
|
||||
(Members '[Error ScoperError, NameIdGen, State ScoperSyntax, State Scope, State ScoperState, Reader BindingStrategy, InfoTableBuilder] r) =>
|
||||
InductiveDef 'Parsed ->
|
||||
Sem r S.Symbol
|
||||
reserveInductiveSymbol d = reserveSymbolSignatureOf SKNameInductive d (d ^. inductiveName)
|
||||
|
||||
reserveAliasSymbol ::
|
||||
Members '[Error ScoperError, NameIdGen, State ScoperSyntax, State Scope, Reader BindingStrategy, InfoTableBuilder, State ScoperState] r =>
|
||||
(Members '[Error ScoperError, NameIdGen, State ScoperSyntax, State Scope, Reader BindingStrategy, InfoTableBuilder, State ScoperState] r) =>
|
||||
Symbol ->
|
||||
Sem r S.Symbol
|
||||
reserveAliasSymbol = reserveSymbolOf SKNameAlias Nothing
|
||||
|
||||
reserveProjectionSymbol ::
|
||||
Members '[Error ScoperError, NameIdGen, State ScoperSyntax, State Scope, Reader BindingStrategy, InfoTableBuilder, State ScoperState] r =>
|
||||
(Members '[Error ScoperError, NameIdGen, State ScoperSyntax, State Scope, Reader BindingStrategy, InfoTableBuilder, State ScoperState] r) =>
|
||||
ProjectionDef 'Parsed ->
|
||||
Sem r S.Symbol
|
||||
reserveProjectionSymbol d = reserveSymbolOf SKNameFunction Nothing (d ^. projectionField)
|
||||
|
||||
reserveConstructorSymbol ::
|
||||
Members '[Error ScoperError, NameIdGen, State ScoperSyntax, State Scope, State ScoperState, Reader BindingStrategy, InfoTableBuilder] r =>
|
||||
(Members '[Error ScoperError, NameIdGen, State ScoperSyntax, State Scope, State ScoperState, Reader BindingStrategy, InfoTableBuilder] r) =>
|
||||
InductiveDef 'Parsed ->
|
||||
ConstructorDef 'Parsed ->
|
||||
Sem r S.Symbol
|
||||
reserveConstructorSymbol d c = reserveSymbolSignatureOf SKNameConstructor (d, c) (c ^. constructorName)
|
||||
|
||||
reserveFunctionSymbol ::
|
||||
Members '[Error ScoperError, NameIdGen, State ScoperSyntax, State Scope, State ScoperState, Reader BindingStrategy, InfoTableBuilder] r =>
|
||||
(Members '[Error ScoperError, NameIdGen, State ScoperSyntax, State Scope, State ScoperState, Reader BindingStrategy, InfoTableBuilder] r) =>
|
||||
FunctionDef 'Parsed ->
|
||||
Sem r S.Symbol
|
||||
reserveFunctionSymbol f =
|
||||
reserveSymbolSignatureOf SKNameFunction f (f ^. signName)
|
||||
|
||||
reserveAxiomSymbol ::
|
||||
Members '[Error ScoperError, NameIdGen, State ScoperSyntax, State Scope, State ScoperState, Reader BindingStrategy, InfoTableBuilder] r =>
|
||||
(Members '[Error ScoperError, NameIdGen, State ScoperSyntax, State Scope, State ScoperState, Reader BindingStrategy, InfoTableBuilder] r) =>
|
||||
AxiomDef 'Parsed ->
|
||||
Sem r S.Symbol
|
||||
reserveAxiomSymbol a = reserveSymbolSignatureOf SKNameAxiom a (a ^. axiomName)
|
||||
|
||||
bindFunctionSymbol ::
|
||||
Members '[Error ScoperError, NameIdGen, State ScoperSyntax, State Scope, InfoTableBuilder, State ScoperState, Reader BindingStrategy] r =>
|
||||
(Members '[Error ScoperError, NameIdGen, State ScoperSyntax, State Scope, InfoTableBuilder, State ScoperState, Reader BindingStrategy] r) =>
|
||||
Symbol ->
|
||||
Sem r S.Symbol
|
||||
bindFunctionSymbol = getReservedDefinitionSymbol
|
||||
|
||||
bindInductiveSymbol ::
|
||||
Members '[Error ScoperError, NameIdGen, State ScoperSyntax, State Scope, InfoTableBuilder, State ScoperState, Reader BindingStrategy] r =>
|
||||
(Members '[Error ScoperError, NameIdGen, State ScoperSyntax, State Scope, InfoTableBuilder, State ScoperState, Reader BindingStrategy] r) =>
|
||||
Symbol ->
|
||||
Sem r S.Symbol
|
||||
bindInductiveSymbol = getReservedDefinitionSymbol
|
||||
|
||||
bindAxiomSymbol ::
|
||||
Members '[Error ScoperError, NameIdGen, State ScoperSyntax, State Scope, InfoTableBuilder, State ScoperState, Reader BindingStrategy] r =>
|
||||
(Members '[Error ScoperError, NameIdGen, State ScoperSyntax, State Scope, InfoTableBuilder, State ScoperState, Reader BindingStrategy] r) =>
|
||||
Symbol ->
|
||||
Sem r S.Symbol
|
||||
bindAxiomSymbol = getReservedDefinitionSymbol
|
||||
|
||||
bindConstructorSymbol ::
|
||||
Members '[Error ScoperError, NameIdGen, State ScoperSyntax, State Scope, InfoTableBuilder, State ScoperState, Reader BindingStrategy] r =>
|
||||
(Members '[Error ScoperError, NameIdGen, State ScoperSyntax, State Scope, InfoTableBuilder, State ScoperState, Reader BindingStrategy] r) =>
|
||||
Symbol ->
|
||||
Sem r S.Symbol
|
||||
bindConstructorSymbol = getReservedDefinitionSymbol
|
||||
|
||||
bindFixitySymbol ::
|
||||
Members '[Error ScoperError, NameIdGen, State ScoperSyntax, State Scope, InfoTableBuilder, State ScoperState, Reader BindingStrategy] r =>
|
||||
(Members '[Error ScoperError, NameIdGen, State ScoperSyntax, State Scope, InfoTableBuilder, State ScoperState, Reader BindingStrategy] r) =>
|
||||
Symbol ->
|
||||
Sem r S.Symbol
|
||||
bindFixitySymbol s = do
|
||||
@ -405,7 +405,7 @@ getTopModulePath Module {..} =
|
||||
S._absLocalPath = mempty
|
||||
}
|
||||
|
||||
getModuleExportInfo :: forall r. Members '[State ScoperState] r => ModuleSymbolEntry -> Sem r ExportInfo
|
||||
getModuleExportInfo :: forall r. (Members '[State ScoperState] r) => ModuleSymbolEntry -> Sem r ExportInfo
|
||||
getModuleExportInfo m = fromMaybeM err (gets (^? scoperModules . at (m ^. moduleEntry . S.nameId) . _Just . to getModuleRefExportInfo))
|
||||
where
|
||||
err :: Sem r a
|
||||
@ -421,7 +421,7 @@ getModuleExportInfo m = fromMaybeM err (gets (^? scoperModules . at (m ^. module
|
||||
-- | Do not call directly. Looks for a symbol in (possibly) nested local modules
|
||||
lookupSymbolAux ::
|
||||
forall r.
|
||||
Members '[State ScoperState, State Scope, Output ModuleSymbolEntry, Output PreSymbolEntry, Output FixitySymbolEntry] r =>
|
||||
(Members '[State ScoperState, State Scope, Output ModuleSymbolEntry, Output PreSymbolEntry, Output FixitySymbolEntry] r) =>
|
||||
[Symbol] ->
|
||||
Symbol ->
|
||||
Sem r ()
|
||||
@ -459,7 +459,7 @@ mkModuleEntry (ModuleRef' (t :&: m)) = ModuleSymbolEntry $ case t of
|
||||
|
||||
lookInExport ::
|
||||
forall r.
|
||||
Members '[State ScoperState, Output PreSymbolEntry, Output ModuleSymbolEntry, Output FixitySymbolEntry] r =>
|
||||
(Members '[State ScoperState, Output PreSymbolEntry, Output ModuleSymbolEntry, Output FixitySymbolEntry] r) =>
|
||||
Symbol ->
|
||||
[Symbol] ->
|
||||
ExportInfo ->
|
||||
@ -479,7 +479,7 @@ lookInExport sym remaining e = case remaining of
|
||||
-- modules due to nesting.
|
||||
lookupQualifiedSymbol ::
|
||||
forall r.
|
||||
Members '[State Scope, State ScoperState] r =>
|
||||
(Members '[State Scope, State ScoperState] r) =>
|
||||
([Symbol], Symbol) ->
|
||||
Sem r ([PreSymbolEntry], [ModuleSymbolEntry], [FixitySymbolEntry])
|
||||
lookupQualifiedSymbol sms = do
|
||||
@ -488,7 +488,7 @@ lookupQualifiedSymbol sms = do
|
||||
where
|
||||
go ::
|
||||
forall r'.
|
||||
Members '[State ScoperState, State Scope, Output PreSymbolEntry, Output ModuleSymbolEntry, Output FixitySymbolEntry] r' =>
|
||||
(Members '[State ScoperState, State Scope, Output PreSymbolEntry, Output ModuleSymbolEntry, Output FixitySymbolEntry] r') =>
|
||||
([Symbol], Symbol) ->
|
||||
Sem r' ()
|
||||
go (path, sym) = do
|
||||
@ -522,7 +522,7 @@ lookupQualifiedSymbol sms = do
|
||||
]
|
||||
|
||||
-- | This assumes that alias do not have cycles.
|
||||
normalizePreSymbolEntry :: Members '[State ScoperState] r => PreSymbolEntry -> Sem r SymbolEntry
|
||||
normalizePreSymbolEntry :: (Members '[State ScoperState] r) => PreSymbolEntry -> Sem r SymbolEntry
|
||||
normalizePreSymbolEntry = \case
|
||||
PreSymbolFinal a -> return a
|
||||
PreSymbolAlias a -> gets (^?! scoperAlias . at (a ^. aliasName . S.nameId) . _Just) >>= normalizePreSymbolEntry
|
||||
@ -542,7 +542,7 @@ checkQualifiedName q@(QualifiedName (SymbolPath p) sym) = do
|
||||
notInScope = throw (ErrQualSymNotInScope (QualSymNotInScope q))
|
||||
|
||||
entryToScopedIden ::
|
||||
Members '[InfoTableBuilder, State ScoperState] r =>
|
||||
(Members '[InfoTableBuilder, State ScoperState] r) =>
|
||||
Name ->
|
||||
PreSymbolEntry ->
|
||||
Sem r ScopedIden
|
||||
@ -571,7 +571,7 @@ entryToScopedIden name e = do
|
||||
-- | We gather all symbols which have been defined or marked to be public in the given scope.
|
||||
exportScope ::
|
||||
forall r.
|
||||
Members '[State Scope, Error ScoperError] r =>
|
||||
(Members '[State Scope, Error ScoperError] r) =>
|
||||
Scope ->
|
||||
Sem r ExportInfo
|
||||
exportScope Scope {..} = do
|
||||
@ -582,7 +582,7 @@ exportScope Scope {..} = do
|
||||
where
|
||||
mkentry ::
|
||||
forall ns.
|
||||
SingI ns =>
|
||||
(SingI ns) =>
|
||||
(Symbol, SymbolInfo ns) ->
|
||||
Sem r (Maybe (Symbol, NameSpaceEntryType ns))
|
||||
mkentry (s, SymbolInfo {..}) =
|
||||
@ -609,7 +609,7 @@ exportScope Scope {..} = do
|
||||
)
|
||||
)
|
||||
|
||||
getParsedModule :: Members '[Reader ScopeParameters] r => TopModulePath -> Sem r (Module 'Parsed 'ModuleTop)
|
||||
getParsedModule :: (Members '[Reader ScopeParameters] r) => TopModulePath -> Sem r (Module 'Parsed 'ModuleTop)
|
||||
getParsedModule i = asks (^?! scopeParsedModules . at i . _Just)
|
||||
|
||||
readScopeModule ::
|
||||
@ -625,7 +625,7 @@ readScopeModule import_ = do
|
||||
|
||||
checkFixitySyntaxDef ::
|
||||
forall r.
|
||||
Members '[Error ScoperError, Reader ScopeParameters, State Scope, State ScoperState, State ScoperSyntax, NameIdGen, InfoTableBuilder] r =>
|
||||
(Members '[Error ScoperError, Reader ScopeParameters, State Scope, State ScoperState, State ScoperSyntax, NameIdGen, InfoTableBuilder] r) =>
|
||||
FixitySyntaxDef 'Parsed ->
|
||||
Sem r (FixitySyntaxDef 'Scoped)
|
||||
checkFixitySyntaxDef FixitySyntaxDef {..} = topBindings $ do
|
||||
@ -641,7 +641,7 @@ checkFixitySyntaxDef FixitySyntaxDef {..} = topBindings $ do
|
||||
|
||||
resolveFixitySyntaxDef ::
|
||||
forall r.
|
||||
Members '[Error ScoperError, Reader ScopeParameters, State Scope, State ScoperState, State ScoperSyntax, NameIdGen, InfoTableBuilder] r =>
|
||||
(Members '[Error ScoperError, Reader ScopeParameters, State Scope, State ScoperState, State ScoperSyntax, NameIdGen, InfoTableBuilder] r) =>
|
||||
FixitySyntaxDef 'Parsed ->
|
||||
Sem r ()
|
||||
resolveFixitySyntaxDef fdef@FixitySyntaxDef {..} = topBindings $ do
|
||||
@ -691,7 +691,7 @@ resolveFixitySyntaxDef fdef@FixitySyntaxDef {..} = topBindings $ do
|
||||
where
|
||||
checkMaybeFixity ::
|
||||
forall r'.
|
||||
Members '[Error ScoperError, State Scope, State ScoperState] r' =>
|
||||
(Members '[Error ScoperError, State Scope, State ScoperState] r') =>
|
||||
Interval ->
|
||||
Maybe Text ->
|
||||
Sem r' (Maybe S.Symbol)
|
||||
@ -710,7 +710,7 @@ resolveFixitySyntaxDef fdef@FixitySyntaxDef {..} = topBindings $ do
|
||||
|
||||
resolveOperatorSyntaxDef ::
|
||||
forall r.
|
||||
Members '[Error ScoperError, State Scope, State ScoperState, State ScoperSyntax, InfoTableBuilder] r =>
|
||||
(Members '[Error ScoperError, State Scope, State ScoperState, State ScoperSyntax, InfoTableBuilder] r) =>
|
||||
OperatorSyntaxDef ->
|
||||
Sem r ()
|
||||
resolveOperatorSyntaxDef s@OperatorSyntaxDef {..} = do
|
||||
@ -734,7 +734,7 @@ resolveOperatorSyntaxDef s@OperatorSyntaxDef {..} = do
|
||||
|
||||
resolveIteratorSyntaxDef ::
|
||||
forall r.
|
||||
Members '[Error ScoperError, State Scope, State ScoperState, State ScoperSyntax] r =>
|
||||
(Members '[Error ScoperError, State Scope, State ScoperState, State ScoperSyntax] r) =>
|
||||
IteratorSyntaxDef ->
|
||||
Sem r ()
|
||||
resolveIteratorSyntaxDef s@IteratorSyntaxDef {..} = do
|
||||
@ -753,12 +753,12 @@ resolveIteratorSyntaxDef s@IteratorSyntaxDef {..} = do
|
||||
$ \s' -> throw (ErrDuplicateIterator (DuplicateIterator (s' ^. symbolIteratorDef) s))
|
||||
|
||||
-- | Only used as syntactical convenience for registerX functions
|
||||
(@$>) :: Functor m => (a -> m ()) -> a -> m a
|
||||
(@$>) :: (Functor m) => (a -> m ()) -> a -> m a
|
||||
(@$>) f a = f a $> a
|
||||
|
||||
checkFunctionDef ::
|
||||
forall r.
|
||||
Members '[Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen, State ScoperSyntax, Reader BindingStrategy] r =>
|
||||
(Members '[Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen, State ScoperSyntax, Reader BindingStrategy] r) =>
|
||||
FunctionDef 'Parsed ->
|
||||
Sem r (FunctionDef 'Scoped)
|
||||
checkFunctionDef FunctionDef {..} = do
|
||||
@ -820,7 +820,7 @@ checkFunctionDef FunctionDef {..} = do
|
||||
|
||||
checkInductiveParameters ::
|
||||
forall r.
|
||||
Members '[Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen] r =>
|
||||
(Members '[Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen] r) =>
|
||||
InductiveParameters 'Parsed ->
|
||||
Sem r (InductiveParameters 'Scoped)
|
||||
checkInductiveParameters params = do
|
||||
@ -836,7 +836,7 @@ checkInductiveParameters params = do
|
||||
|
||||
checkInductiveDef ::
|
||||
forall r.
|
||||
Members '[Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen, State ScoperSyntax, Reader BindingStrategy] r =>
|
||||
(Members '[Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen, State ScoperSyntax, Reader BindingStrategy] r) =>
|
||||
InductiveDef 'Parsed ->
|
||||
Sem r (InductiveDef 'Scoped)
|
||||
checkInductiveDef InductiveDef {..} = do
|
||||
@ -1013,7 +1013,7 @@ checkTopModule m@Module {..} = do
|
||||
modify (set (scoperScope . at (p ^. S.nameConcrete)) (Just s))
|
||||
return m'
|
||||
|
||||
withTopScope :: Members '[State Scope] r => Sem r a -> Sem r a
|
||||
withTopScope :: (Members '[State Scope] r) => Sem r a -> Sem r a
|
||||
withTopScope ma = do
|
||||
before <- get @Scope
|
||||
let scope' =
|
||||
@ -1024,7 +1024,7 @@ withTopScope ma = do
|
||||
put scope'
|
||||
ma
|
||||
|
||||
withLocalScope :: Members '[State Scope] r => Sem r a -> Sem r a
|
||||
withLocalScope :: (Members '[State Scope] r) => Sem r a -> Sem r a
|
||||
withLocalScope ma = do
|
||||
before <- get @Scope
|
||||
let scope' =
|
||||
@ -1037,7 +1037,7 @@ withLocalScope ma = do
|
||||
put before
|
||||
return x
|
||||
|
||||
syntaxBlock :: Members '[Error ScoperError] r => Sem (State ScoperSyntax ': r) a -> Sem r a
|
||||
syntaxBlock :: (Members '[Error ScoperError] r) => Sem (State ScoperSyntax ': r) a -> Sem r a
|
||||
syntaxBlock m =
|
||||
evalState emptyScoperSyntax $ do
|
||||
a <- m
|
||||
@ -1047,7 +1047,7 @@ syntaxBlock m =
|
||||
|
||||
checkModuleBody ::
|
||||
forall r.
|
||||
Members '[Error ScoperError, State Scope, Reader ScopeParameters, State ScoperState, InfoTableBuilder, NameIdGen, Reader BindingStrategy] r =>
|
||||
(Members '[Error ScoperError, State Scope, Reader ScopeParameters, State ScoperState, InfoTableBuilder, NameIdGen, Reader BindingStrategy] r) =>
|
||||
[Statement 'Parsed] ->
|
||||
Sem r (ExportInfo, [Statement 'Scoped])
|
||||
checkModuleBody body = do
|
||||
@ -1064,7 +1064,7 @@ checkModuleBody body = do
|
||||
SectionsNonDefinitions n -> goNonDefinitions n
|
||||
SectionsDefinitions n -> goDefinitions n
|
||||
where
|
||||
goNonDefinitions :: forall t. Members '[Output (Statement s)] t => NonDefinitionsSection s -> Sem t ()
|
||||
goNonDefinitions :: forall t. (Members '[Output (Statement s)] t) => NonDefinitionsSection s -> Sem t ()
|
||||
goNonDefinitions NonDefinitionsSection {..} = do
|
||||
mapM_ (output . toStatement) _nonDefinitionsSection
|
||||
whenJust _nonDefinitionsNext goDefinitions
|
||||
@ -1075,7 +1075,7 @@ checkModuleBody body = do
|
||||
NonDefinitionModule d -> StatementModule d
|
||||
NonDefinitionOpenModule d -> StatementOpenModule d
|
||||
|
||||
goDefinitions :: forall t. Members '[Output (Statement s)] t => DefinitionsSection s -> Sem t ()
|
||||
goDefinitions :: forall t. (Members '[Output (Statement s)] t) => DefinitionsSection s -> Sem t ()
|
||||
goDefinitions DefinitionsSection {..} = do
|
||||
mapM_ (output . toStatement) _definitionsSection
|
||||
whenJust _definitionsNext goNonDefinitions
|
||||
@ -1090,7 +1090,7 @@ checkModuleBody body = do
|
||||
|
||||
checkSections ::
|
||||
forall r.
|
||||
Members '[Error ScoperError, Reader ScopeParameters, State Scope, State ScoperState, InfoTableBuilder, NameIdGen, State ScoperSyntax] r =>
|
||||
(Members '[Error ScoperError, Reader ScopeParameters, State Scope, State ScoperState, InfoTableBuilder, NameIdGen, State ScoperSyntax] r) =>
|
||||
StatementSections 'Parsed ->
|
||||
Sem r (StatementSections 'Scoped)
|
||||
checkSections sec = do
|
||||
@ -1159,7 +1159,7 @@ checkSections sec = do
|
||||
checkLoop :: NameId -> Sem r' ()
|
||||
checkLoop = evalState (mempty :: HashSet NameId) . go
|
||||
where
|
||||
go :: Members '[State (HashSet NameId), Error ScoperError, State ScoperState] s => NameId -> Sem s ()
|
||||
go :: (Members '[State (HashSet NameId), Error ScoperError, State ScoperState] s) => NameId -> Sem s ()
|
||||
go i = do
|
||||
whenM (gets (HashSet.member i)) (throw (ErrAliasCycle (AliasCycle a)))
|
||||
modify' (HashSet.insert i)
|
||||
@ -1220,7 +1220,7 @@ checkSections sec = do
|
||||
m <- runReader (getLoc (i ^. inductiveName)) genModule
|
||||
checkLocalModule m >>= output
|
||||
where
|
||||
genModule :: forall s'. Members '[Reader Interval] s' => Sem s' (Module 'Parsed 'ModuleLocal)
|
||||
genModule :: forall s'. (Members '[Reader Interval] s') => Sem s' (Module 'Parsed 'ModuleLocal)
|
||||
genModule = do
|
||||
_moduleKw <- G.kw G.kwModule
|
||||
_moduleKwEnd <- G.kw G.kwEnd
|
||||
@ -1314,7 +1314,7 @@ mkSections = \case
|
||||
StatementOpenModule o -> Right (NonDefinitionOpenModule o)
|
||||
|
||||
reserveLocalModuleSymbol ::
|
||||
Members '[Error ScoperError, State Scope, Reader ScopeParameters, State ScoperState, InfoTableBuilder, NameIdGen, Reader BindingStrategy] r =>
|
||||
(Members '[Error ScoperError, State Scope, Reader ScopeParameters, State ScoperState, InfoTableBuilder, NameIdGen, Reader BindingStrategy] r) =>
|
||||
Symbol ->
|
||||
Sem r S.Symbol
|
||||
reserveLocalModuleSymbol =
|
||||
@ -1322,7 +1322,7 @@ reserveLocalModuleSymbol =
|
||||
|
||||
checkLocalModule ::
|
||||
forall r.
|
||||
Members '[Error ScoperError, State Scope, Reader ScopeParameters, State ScoperState, InfoTableBuilder, NameIdGen, Reader BindingStrategy] r =>
|
||||
(Members '[Error ScoperError, State Scope, Reader ScopeParameters, State ScoperState, InfoTableBuilder, NameIdGen, Reader BindingStrategy] r) =>
|
||||
Module 'Parsed 'ModuleLocal ->
|
||||
Sem r (Module 'Scoped 'ModuleLocal)
|
||||
checkLocalModule Module {..} = do
|
||||
@ -1358,7 +1358,7 @@ checkLocalModule Module {..} = do
|
||||
modify (over scopeSymbols (fmap inheritSymbol))
|
||||
modify (over scopeModuleSymbols (fmap inheritSymbol))
|
||||
where
|
||||
inheritSymbol :: forall ns. SingI ns => SymbolInfo ns -> SymbolInfo ns
|
||||
inheritSymbol :: forall ns. (SingI ns) => SymbolInfo ns -> SymbolInfo ns
|
||||
inheritSymbol (SymbolInfo s) = SymbolInfo (inheritEntry <$> s)
|
||||
where
|
||||
inheritEntry :: NameSpaceEntryType ns -> NameSpaceEntryType ns
|
||||
@ -1366,7 +1366,7 @@ checkLocalModule Module {..} = do
|
||||
over (nsEntry . S.nameWhyInScope) S.BecauseInherited
|
||||
. set (nsEntry . S.nameVisibilityAnn) VisPrivate
|
||||
|
||||
checkOrphanOperators :: forall r. Members '[Error ScoperError, State ScoperSyntax] r => Sem r ()
|
||||
checkOrphanOperators :: forall r. (Members '[Error ScoperError, State ScoperSyntax] r) => Sem r ()
|
||||
checkOrphanOperators = do
|
||||
declared <- gets (^. scoperSyntaxOperators . scoperOperators)
|
||||
let unused = fmap (^. symbolOperatorDef) . find (^. symbolOperatorUsed . to not) . toList $ declared
|
||||
@ -1374,7 +1374,7 @@ checkOrphanOperators = do
|
||||
Nothing -> return ()
|
||||
Just x -> throw (ErrUnusedOperatorDef (UnusedOperatorDef x))
|
||||
|
||||
checkOrphanIterators :: forall r. Members '[Error ScoperError, State ScoperSyntax] r => Sem r ()
|
||||
checkOrphanIterators :: forall r. (Members '[Error ScoperError, State ScoperSyntax] r) => Sem r ()
|
||||
checkOrphanIterators = do
|
||||
declared <- gets (^. scoperSyntaxIterators . scoperIterators)
|
||||
let unused = fmap (^. symbolIteratorDef) . find (^. symbolIteratorUsed . to not) . toList $ declared
|
||||
@ -1382,11 +1382,11 @@ checkOrphanIterators = do
|
||||
Nothing -> return ()
|
||||
Just x -> throw (ErrUnusedIteratorDef (UnusedIteratorDef x))
|
||||
|
||||
symbolInfoSingle :: SingI ns => NameSpaceEntryType ns -> SymbolInfo ns
|
||||
symbolInfoSingle :: (SingI ns) => NameSpaceEntryType ns -> SymbolInfo ns
|
||||
symbolInfoSingle p = SymbolInfo $ HashMap.singleton (p ^. nsEntry . S.nameDefinedIn) p
|
||||
|
||||
getModuleRef ::
|
||||
Members '[State ScoperState] r =>
|
||||
(Members '[State ScoperState] r) =>
|
||||
ModuleSymbolEntry ->
|
||||
Name ->
|
||||
Sem r ModuleRef
|
||||
@ -1395,7 +1395,7 @@ getModuleRef e n =
|
||||
<$> gets (^?! scoperModules . at (e ^. moduleEntry . S.nameId) . _Just)
|
||||
|
||||
lookupModuleSymbol ::
|
||||
Members '[Error ScoperError, State Scope, State ScoperState] r =>
|
||||
(Members '[Error ScoperError, State Scope, State ScoperState] r) =>
|
||||
Name ->
|
||||
Sem r ModuleRef
|
||||
lookupModuleSymbol n = do
|
||||
@ -1443,7 +1443,7 @@ checkOpenImportModule op
|
||||
|
||||
checkOpenModuleNoImport ::
|
||||
forall r.
|
||||
Members '[Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen] r =>
|
||||
(Members '[Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen] r) =>
|
||||
Maybe (ModuleRef'' 'S.Concrete 'ModuleTop) ->
|
||||
OpenModule 'Parsed ->
|
||||
Sem r (OpenModule 'Scoped)
|
||||
@ -1461,7 +1461,7 @@ checkOpenModuleNoImport importModuleHint OpenModule {..}
|
||||
Hiding h -> Hiding <$> checkHidingList h
|
||||
Using uh -> Using <$> checkUsingList uh
|
||||
where
|
||||
scopeSymbol :: forall (ns :: NameSpace). SingI ns => Sing ns -> Symbol -> Sem r S.Symbol
|
||||
scopeSymbol :: forall (ns :: NameSpace). (SingI ns) => Sing ns -> Symbol -> Sem r S.Symbol
|
||||
scopeSymbol _ s = do
|
||||
let mentry :: Maybe (NameSpaceEntryType ns)
|
||||
mentry = exportInfo ^. exportNameSpace . at s
|
||||
@ -1547,7 +1547,7 @@ checkOpenModuleNoImport importModuleHint OpenModule {..}
|
||||
mapM_ mergeSymbol (HashMap.toList (ei ^. exportModuleSymbols))
|
||||
mapM_ mergeSymbol (HashMap.toList (ei ^. exportFixitySymbols))
|
||||
where
|
||||
mergeSymbol :: forall ns. SingI ns => (Symbol, NameSpaceEntryType ns) -> Sem r ()
|
||||
mergeSymbol :: forall ns. (SingI ns) => (Symbol, NameSpaceEntryType ns) -> Sem r ()
|
||||
mergeSymbol (s, entry) =
|
||||
modify
|
||||
(over scopeNameSpace (HashMap.insertWith (<>) s (symbolInfoSingle entry)))
|
||||
@ -1563,7 +1563,7 @@ checkOpenModuleNoImport importModuleHint OpenModule {..}
|
||||
_exportFixitySymbols = alterEntry <$> nfo ^. exportFixitySymbols
|
||||
}
|
||||
|
||||
alterEntry :: SingI ns => NameSpaceEntryType ns -> NameSpaceEntryType ns
|
||||
alterEntry :: (SingI ns) => NameSpaceEntryType ns -> NameSpaceEntryType ns
|
||||
alterEntry =
|
||||
over
|
||||
nsEntry
|
||||
@ -1585,7 +1585,7 @@ checkOpenModuleNoImport importModuleHint OpenModule {..}
|
||||
where
|
||||
inUsing ::
|
||||
forall (ns :: NameSpace).
|
||||
SingI ns =>
|
||||
(SingI ns) =>
|
||||
(Symbol, NameSpaceEntryType ns) ->
|
||||
Maybe (Symbol, NameSpaceEntryType ns)
|
||||
inUsing (sym, e) = do
|
||||
@ -1602,7 +1602,7 @@ checkOpenModuleNoImport importModuleHint OpenModule {..}
|
||||
. over exportModuleSymbols (HashMap.filter (not . inHiding))
|
||||
. over exportFixitySymbols (HashMap.filter (not . inHiding))
|
||||
where
|
||||
inHiding :: forall ns. SingI ns => NameSpaceEntryType ns -> Bool
|
||||
inHiding :: forall ns. (SingI ns) => NameSpaceEntryType ns -> Bool
|
||||
inHiding e = HashSet.member (e ^. nsEntry . S.nameId) u
|
||||
u :: HashSet NameId
|
||||
u = HashSet.fromList (map (^. hidingSymbol . S.nameId) (toList (l ^. hidingList)))
|
||||
@ -1618,7 +1618,7 @@ checkOpenModule op
|
||||
| otherwise = checkOpenModuleNoImport Nothing op
|
||||
|
||||
checkAxiomDef ::
|
||||
Members '[Reader ScopeParameters, InfoTableBuilder, Error ScoperError, State Scope, State ScoperState, NameIdGen, State ScoperSyntax, Reader BindingStrategy] r =>
|
||||
(Members '[Reader ScopeParameters, InfoTableBuilder, Error ScoperError, State Scope, State ScoperState, NameIdGen, State ScoperSyntax, Reader BindingStrategy] r) =>
|
||||
AxiomDef 'Parsed ->
|
||||
Sem r (AxiomDef 'Scoped)
|
||||
checkAxiomDef AxiomDef {..} = do
|
||||
@ -1627,12 +1627,12 @@ checkAxiomDef AxiomDef {..} = do
|
||||
axiomDoc' <- withLocalScope (mapM checkJudoc _axiomDoc)
|
||||
registerAxiom @$> AxiomDef {_axiomName = axiomName', _axiomType = axiomType', _axiomDoc = axiomDoc', ..}
|
||||
|
||||
entryToSymbol :: forall (ns :: NameSpace). SingI ns => NameSpaceEntryType ns -> Symbol -> S.Symbol
|
||||
entryToSymbol :: forall (ns :: NameSpace). (SingI ns) => NameSpaceEntryType ns -> Symbol -> S.Symbol
|
||||
entryToSymbol sentry csym = set S.nameConcrete csym (sentry ^. nsEntry)
|
||||
|
||||
checkFunction ::
|
||||
forall r.
|
||||
Members '[Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen] r =>
|
||||
(Members '[Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen] r) =>
|
||||
Function 'Parsed ->
|
||||
Sem r (Function 'Scoped)
|
||||
checkFunction f = do
|
||||
@ -1651,7 +1651,7 @@ checkFunction f = do
|
||||
|
||||
-- | for now functions defined in let clauses cannot be infix operators
|
||||
checkLetFunDefs ::
|
||||
Members '[Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen] r =>
|
||||
(Members '[Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen] r) =>
|
||||
NonEmpty (LetStatement 'Parsed) ->
|
||||
Sem r (NonEmpty (LetStatement 'Scoped))
|
||||
checkLetFunDefs =
|
||||
@ -1698,7 +1698,7 @@ checkLetFunDefs =
|
||||
|
||||
checkRecordPattern ::
|
||||
forall r.
|
||||
Members '[Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen] r =>
|
||||
(Members '[Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen] r) =>
|
||||
RecordPattern 'Parsed ->
|
||||
Sem r (RecordPattern 'Scoped)
|
||||
checkRecordPattern r = do
|
||||
@ -1721,7 +1721,7 @@ checkRecordPattern r = do
|
||||
noFields = ErrConstructorNotARecord . ConstructorNotARecord
|
||||
checkItem ::
|
||||
forall r'.
|
||||
Members '[Reader RecordNameSignature, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen] r' =>
|
||||
(Members '[Reader RecordNameSignature, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen] r') =>
|
||||
RecordPatternItem 'Parsed ->
|
||||
Sem r' (RecordPatternItem 'Scoped)
|
||||
checkItem = \case
|
||||
@ -1757,7 +1757,7 @@ checkRecordPattern r = do
|
||||
|
||||
checkListPattern ::
|
||||
forall r.
|
||||
Members '[Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen] r =>
|
||||
(Members '[Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen] r) =>
|
||||
ListPattern 'Parsed ->
|
||||
Sem r (ListPattern 'Scoped)
|
||||
checkListPattern l = do
|
||||
@ -1768,7 +1768,7 @@ checkListPattern l = do
|
||||
|
||||
checkList ::
|
||||
forall r.
|
||||
Members '[Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen] r =>
|
||||
(Members '[Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen] r) =>
|
||||
List 'Parsed ->
|
||||
Sem r (List 'Scoped)
|
||||
checkList l = do
|
||||
@ -1779,7 +1779,7 @@ checkList l = do
|
||||
|
||||
checkLet ::
|
||||
forall r.
|
||||
Members '[Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen] r =>
|
||||
(Members '[Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen] r) =>
|
||||
Let 'Parsed ->
|
||||
Sem r (Let 'Scoped)
|
||||
checkLet Let {..} =
|
||||
@ -1796,7 +1796,7 @@ checkLet Let {..} =
|
||||
|
||||
checkCaseBranch ::
|
||||
forall r.
|
||||
Members '[Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen] r =>
|
||||
(Members '[Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen] r) =>
|
||||
CaseBranch 'Parsed ->
|
||||
Sem r (CaseBranch 'Scoped)
|
||||
checkCaseBranch CaseBranch {..} = withLocalScope $ do
|
||||
@ -1817,7 +1817,7 @@ checkCaseBranch CaseBranch {..} = withLocalScope $ do
|
||||
(throw (ErrCaseBranchImplicitPattern (CaseBranchImplicitPattern p)))
|
||||
|
||||
checkCase ::
|
||||
Members '[Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen] r =>
|
||||
(Members '[Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen] r) =>
|
||||
Case 'Parsed ->
|
||||
Sem r (Case 'Scoped)
|
||||
checkCase Case {..} = do
|
||||
@ -1832,7 +1832,7 @@ checkCase Case {..} = do
|
||||
}
|
||||
|
||||
checkLambda ::
|
||||
Members '[Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen] r =>
|
||||
(Members '[Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen] r) =>
|
||||
Lambda 'Parsed ->
|
||||
Sem r (Lambda 'Scoped)
|
||||
checkLambda Lambda {..} = do
|
||||
@ -1845,7 +1845,7 @@ checkLambda Lambda {..} = do
|
||||
}
|
||||
|
||||
checkLambdaClause ::
|
||||
Members '[Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen] r =>
|
||||
(Members '[Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen] r) =>
|
||||
LambdaClause 'Parsed ->
|
||||
Sem r (LambdaClause 'Scoped)
|
||||
checkLambdaClause LambdaClause {..} = withLocalScope $ do
|
||||
@ -1893,7 +1893,7 @@ checkFixitySymbol s = do
|
||||
-- shadowing rules for modules. For example, a symbol defined in the outer
|
||||
-- module with the same name as a symbol defined in the inner module will be
|
||||
-- removed.
|
||||
resolveShadowing :: forall ns. SingI ns => [NameSpaceEntryType ns] -> [NameSpaceEntryType ns]
|
||||
resolveShadowing :: forall ns. (SingI ns) => [NameSpaceEntryType ns] -> [NameSpaceEntryType ns]
|
||||
resolveShadowing es = go [(e, e ^. nsEntry . S.nameWhyInScope) | e <- es]
|
||||
where
|
||||
go :: [(NameSpaceEntryType ns, S.WhyInScope)] -> [NameSpaceEntryType ns]
|
||||
@ -1915,7 +1915,7 @@ resolveShadowing es = go [(e, e ^. nsEntry . S.nameWhyInScope) | e <- es]
|
||||
|
||||
checkPatternName ::
|
||||
forall r.
|
||||
Members '[Error ScoperError, State Scope, NameIdGen, State ScoperState, InfoTableBuilder] r =>
|
||||
(Members '[Error ScoperError, State Scope, NameIdGen, State ScoperState, InfoTableBuilder] r) =>
|
||||
Name ->
|
||||
Sem r PatternScopedIden
|
||||
checkPatternName n = do
|
||||
@ -1930,7 +1930,7 @@ checkPatternName n = do
|
||||
getConstructorRef :: Sem r (Maybe ScopedIden)
|
||||
getConstructorRef = lookupNameOfKind KNameConstructor n
|
||||
|
||||
nameNotInScope :: forall r a. Members '[Error ScoperError, State Scope] r => Name -> Sem r a
|
||||
nameNotInScope :: forall r a. (Members '[Error ScoperError, State Scope] r) => Name -> Sem r a
|
||||
nameNotInScope n = err >>= throw
|
||||
where
|
||||
err :: Sem r ScoperError
|
||||
@ -1940,7 +1940,7 @@ nameNotInScope n = err >>= throw
|
||||
|
||||
getNameOfKind ::
|
||||
forall r.
|
||||
Members '[Error ScoperError, State Scope, State ScoperState, InfoTableBuilder] r =>
|
||||
(Members '[Error ScoperError, State Scope, State ScoperState, InfoTableBuilder] r) =>
|
||||
NameKind ->
|
||||
Name ->
|
||||
Sem r ScopedIden
|
||||
@ -1948,7 +1948,7 @@ getNameOfKind nameKind n = fromMaybeM (nameNotInScope n) (lookupNameOfKind nameK
|
||||
|
||||
lookupNameOfKind ::
|
||||
forall r.
|
||||
Members '[Error ScoperError, State Scope, State ScoperState, InfoTableBuilder] r =>
|
||||
(Members '[Error ScoperError, State Scope, State ScoperState, InfoTableBuilder] r) =>
|
||||
NameKind ->
|
||||
Name ->
|
||||
Sem r (Maybe ScopedIden)
|
||||
@ -1968,7 +1968,7 @@ lookupNameOfKind nameKind n = do
|
||||
return (e, e')
|
||||
|
||||
checkPatternBinding ::
|
||||
Members '[Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen] r =>
|
||||
(Members '[Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen] r) =>
|
||||
PatternBinding ->
|
||||
Sem r PatternArg
|
||||
checkPatternBinding (PatternBinding n p) = do
|
||||
@ -2019,7 +2019,7 @@ checkScopedIden ::
|
||||
checkScopedIden n = checkName n >>= entryToScopedIden n
|
||||
|
||||
checkExpressionAtom ::
|
||||
Members '[Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen] r =>
|
||||
(Members '[Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen] r) =>
|
||||
ExpressionAtom 'Parsed ->
|
||||
Sem r (NonEmpty (ExpressionAtom 'Scoped))
|
||||
checkExpressionAtom e = case e of
|
||||
@ -2039,7 +2039,7 @@ checkExpressionAtom e = case e of
|
||||
AtomNamedApplication i -> pure . AtomNamedApplication <$> checkNamedApplication i
|
||||
AtomRecordUpdate i -> pure . AtomRecordUpdate <$> checkRecordUpdate i
|
||||
|
||||
checkRecordUpdate :: forall r. Members '[Error ScoperError, State Scope, State ScoperState, Reader ScopeParameters, InfoTableBuilder, NameIdGen] r => RecordUpdate 'Parsed -> Sem r (RecordUpdate 'Scoped)
|
||||
checkRecordUpdate :: forall r. (Members '[Error ScoperError, State Scope, State ScoperState, Reader ScopeParameters, InfoTableBuilder, NameIdGen] r) => RecordUpdate 'Parsed -> Sem r (RecordUpdate 'Scoped)
|
||||
checkRecordUpdate RecordUpdate {..} = do
|
||||
tyName' <- getNameOfKind KNameInductive _recordUpdateTypeName
|
||||
info <- getRecordInfo tyName'
|
||||
@ -2080,7 +2080,7 @@ checkRecordUpdate RecordUpdate {..} = do
|
||||
|
||||
checkNamedApplication ::
|
||||
forall r.
|
||||
Members '[Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen] r =>
|
||||
(Members '[Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen] r) =>
|
||||
NamedApplication 'Parsed ->
|
||||
Sem r (NamedApplication 'Scoped)
|
||||
checkNamedApplication napp = do
|
||||
@ -2104,7 +2104,7 @@ checkNamedApplication napp = do
|
||||
|
||||
getRecordInfo ::
|
||||
forall r.
|
||||
Members '[State ScoperState, Error ScoperError] r =>
|
||||
(Members '[State ScoperState, Error ScoperError] r) =>
|
||||
ScopedIden ->
|
||||
Sem r RecordInfo
|
||||
getRecordInfo indTy =
|
||||
@ -2113,7 +2113,7 @@ getRecordInfo indTy =
|
||||
err :: Sem r a
|
||||
err = throw (ErrNotARecord (NotARecord indTy))
|
||||
|
||||
getNameSignature :: Members '[State ScoperState, Error ScoperError] r => ScopedIden -> Sem r NameSignature
|
||||
getNameSignature :: (Members '[State ScoperState, Error ScoperError] r) => ScopedIden -> Sem r NameSignature
|
||||
getNameSignature s = do
|
||||
sig <- maybeM (throw err) return (lookupNameSignature (s ^. scopedIdenFinal . S.nameId))
|
||||
when (null (sig ^. nameSignatureArgs)) (throw err)
|
||||
@ -2121,11 +2121,11 @@ getNameSignature s = do
|
||||
where
|
||||
err = ErrNoNameSignature (NoNameSignature s)
|
||||
|
||||
lookupNameSignature :: Members '[State ScoperState] r => S.NameId -> Sem r (Maybe NameSignature)
|
||||
lookupNameSignature :: (Members '[State ScoperState] r) => S.NameId -> Sem r (Maybe NameSignature)
|
||||
lookupNameSignature s = gets (^. scoperSignatures . at s)
|
||||
|
||||
checkIterator ::
|
||||
Members '[Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen] r =>
|
||||
(Members '[Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen] r) =>
|
||||
Iterator 'Parsed ->
|
||||
Sem r (Iterator 'Scoped)
|
||||
checkIterator iter = do
|
||||
@ -2168,7 +2168,7 @@ checkIterator iter = do
|
||||
return Iterator {..}
|
||||
|
||||
checkInitializer ::
|
||||
Members '[Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen] r =>
|
||||
(Members '[Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen] r) =>
|
||||
Initializer 'Parsed ->
|
||||
Sem r (Initializer 'Scoped)
|
||||
checkInitializer ini = do
|
||||
@ -2181,7 +2181,7 @@ checkInitializer ini = do
|
||||
}
|
||||
|
||||
checkRange ::
|
||||
Members '[Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen] r =>
|
||||
(Members '[Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen] r) =>
|
||||
Range 'Parsed ->
|
||||
Sem r (Range 'Scoped)
|
||||
checkRange rng = do
|
||||
@ -2194,7 +2194,7 @@ checkRange rng = do
|
||||
}
|
||||
|
||||
checkHole ::
|
||||
Members '[NameIdGen] r =>
|
||||
(Members '[NameIdGen] r) =>
|
||||
HoleType 'Parsed ->
|
||||
Sem r Hole
|
||||
checkHole h = do
|
||||
@ -2206,7 +2206,7 @@ checkHole h = do
|
||||
}
|
||||
|
||||
checkParens ::
|
||||
Members '[Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen] r =>
|
||||
(Members '[Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen] r) =>
|
||||
ExpressionAtoms 'Parsed ->
|
||||
Sem r Expression
|
||||
checkParens e@(ExpressionAtoms as _) = case as of
|
||||
@ -2223,19 +2223,19 @@ checkParens e@(ExpressionAtoms as _) = case as of
|
||||
|
||||
checkExpressionAtoms ::
|
||||
forall r.
|
||||
Members '[Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen] r =>
|
||||
(Members '[Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen] r) =>
|
||||
ExpressionAtoms 'Parsed ->
|
||||
Sem r (ExpressionAtoms 'Scoped)
|
||||
checkExpressionAtoms (ExpressionAtoms l i) = (`ExpressionAtoms` i) <$> sconcatMap checkExpressionAtom l
|
||||
|
||||
checkJudoc ::
|
||||
Members '[Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen] r =>
|
||||
(Members '[Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen] r) =>
|
||||
Judoc 'Parsed ->
|
||||
Sem r (Judoc 'Scoped)
|
||||
checkJudoc (Judoc groups) = Judoc <$> mapM checkJudocGroup groups
|
||||
|
||||
checkJudocGroup ::
|
||||
Members '[Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen] r =>
|
||||
(Members '[Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen] r) =>
|
||||
JudocGroup 'Parsed ->
|
||||
Sem r (JudocGroup 'Scoped)
|
||||
checkJudocGroup = \case
|
||||
@ -2243,7 +2243,7 @@ checkJudocGroup = \case
|
||||
JudocGroupLines l -> JudocGroupLines <$> mapM checkJudocBlock l
|
||||
|
||||
checkJudocBlock ::
|
||||
Members '[Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen] r =>
|
||||
(Members '[Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen] r) =>
|
||||
JudocBlock 'Parsed ->
|
||||
Sem r (JudocBlock 'Scoped)
|
||||
checkJudocBlock = \case
|
||||
@ -2251,19 +2251,19 @@ checkJudocBlock = \case
|
||||
JudocExample e -> JudocExample <$> traverseOf exampleExpression checkParseExpressionAtoms e
|
||||
|
||||
checkJudocBlockParagraph ::
|
||||
Members '[Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen] r =>
|
||||
(Members '[Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen] r) =>
|
||||
JudocBlockParagraph 'Parsed ->
|
||||
Sem r (JudocBlockParagraph 'Scoped)
|
||||
checkJudocBlockParagraph = traverseOf judocBlockParagraphBlocks (mapM checkJudocBlock)
|
||||
|
||||
checkJudocLine ::
|
||||
Members '[Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen] r =>
|
||||
(Members '[Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen] r) =>
|
||||
JudocLine 'Parsed ->
|
||||
Sem r (JudocLine 'Scoped)
|
||||
checkJudocLine (JudocLine delim atoms) = JudocLine delim <$> mapM (mapM checkJudocAtom) atoms
|
||||
|
||||
checkJudocAtom ::
|
||||
Members '[Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen] r =>
|
||||
(Members '[Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen] r) =>
|
||||
JudocAtom 'Parsed ->
|
||||
Sem r (JudocAtom 'Scoped)
|
||||
checkJudocAtom = \case
|
||||
@ -2272,7 +2272,7 @@ checkJudocAtom = \case
|
||||
|
||||
checkParseExpressionAtoms ::
|
||||
forall r.
|
||||
Members '[Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen] r =>
|
||||
(Members '[Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen] r) =>
|
||||
ExpressionAtoms 'Parsed ->
|
||||
Sem r Expression
|
||||
checkParseExpressionAtoms = checkExpressionAtoms >=> parseExpressionAtoms
|
||||
@ -2329,7 +2329,7 @@ resolveSyntaxDef = \case
|
||||
|
||||
checkPrecedences ::
|
||||
forall r.
|
||||
Members '[Error ScoperError, InfoTableBuilder] r =>
|
||||
(Members '[Error ScoperError, InfoTableBuilder] r) =>
|
||||
[S.Name] ->
|
||||
Sem r ()
|
||||
checkPrecedences opers = do
|
||||
@ -2351,14 +2351,14 @@ checkPrecedences opers = do
|
||||
(maybe False (\fx -> Just fid == (fx ^. fixityId)) . (^. S.nameFixity))
|
||||
opers
|
||||
|
||||
checkExpressionPrecedences :: Members '[Error ScoperError, InfoTableBuilder] r => ExpressionAtoms 'Scoped -> Sem r ()
|
||||
checkExpressionPrecedences :: (Members '[Error ScoperError, InfoTableBuilder] r) => ExpressionAtoms 'Scoped -> Sem r ()
|
||||
checkExpressionPrecedences (ExpressionAtoms atoms _) =
|
||||
checkPrecedences opers
|
||||
where
|
||||
opers :: [S.Name]
|
||||
opers = mapMaybe P.getExpressionAtomIden (toList atoms)
|
||||
|
||||
checkPatternPrecedences :: Members '[Error ScoperError, InfoTableBuilder] r => PatternAtoms 'Scoped -> Sem r ()
|
||||
checkPatternPrecedences :: (Members '[Error ScoperError, InfoTableBuilder] r) => PatternAtoms 'Scoped -> Sem r ()
|
||||
checkPatternPrecedences (PatternAtoms atoms _) =
|
||||
checkPrecedences opers
|
||||
where
|
||||
|
@ -10,10 +10,10 @@ import Juvix.Data.PPOutput
|
||||
import Juvix.Prelude
|
||||
import Text.EditDistance
|
||||
|
||||
ppCode :: Scoped.PrettyPrint c => Scoped.Options -> c -> Doc Ann
|
||||
ppCode :: (Scoped.PrettyPrint c) => Scoped.Options -> c -> Doc Ann
|
||||
ppCode opts = code . ppMessage opts
|
||||
|
||||
ppMessage :: Scoped.PrettyPrint c => Scoped.Options -> c -> Doc Ann
|
||||
ppMessage :: (Scoped.PrettyPrint c) => Scoped.Options -> c -> Doc Ann
|
||||
ppMessage = Scoped.docNoComments
|
||||
|
||||
prettyError :: Doc Ann -> AnsiText
|
||||
|
@ -581,7 +581,7 @@ newtype CaseBranchImplicitPattern = CaseBranchImplicitPattern
|
||||
deriving stock (Show)
|
||||
|
||||
instance ToGenericError CaseBranchImplicitPattern where
|
||||
genericError :: Member (Reader GenericOptions) r => CaseBranchImplicitPattern -> Sem r GenericError
|
||||
genericError :: (Member (Reader GenericOptions) r) => CaseBranchImplicitPattern -> Sem r GenericError
|
||||
genericError CaseBranchImplicitPattern {..} = do
|
||||
opts <- fromGenericOptions <$> ask
|
||||
let msg = "The pattern" <+> ppCode opts _caseBranchImplicitPattern <+> "is not valid because implicit patterns are not allowed in case branches"
|
||||
@ -602,7 +602,7 @@ data ModuleDoesNotExportSymbol = ModuleDoesNotExportSymbol
|
||||
deriving stock (Show)
|
||||
|
||||
instance ToGenericError ModuleDoesNotExportSymbol where
|
||||
genericError :: Member (Reader GenericOptions) r => ModuleDoesNotExportSymbol -> Sem r GenericError
|
||||
genericError :: (Member (Reader GenericOptions) r) => ModuleDoesNotExportSymbol -> Sem r GenericError
|
||||
genericError ModuleDoesNotExportSymbol {..} = do
|
||||
opts <- fromGenericOptions <$> ask
|
||||
let msg =
|
||||
|
@ -86,7 +86,7 @@ data ReplInput
|
||||
| ReplOpenImport (OpenModule 'Parsed)
|
||||
|
||||
expressionFromTextSource ::
|
||||
Members '[Error JuvixError, NameIdGen] r =>
|
||||
(Members '[Error JuvixError, NameIdGen] r) =>
|
||||
Path Abs File ->
|
||||
Text ->
|
||||
Sem r (ExpressionAtoms 'Parsed)
|
||||
@ -97,14 +97,14 @@ expressionFromTextSource fp txt = mapError (JuvixError @ParserError) $ do
|
||||
Right exp' -> return exp'
|
||||
|
||||
replInputFromTextSource ::
|
||||
Members '[Error JuvixError, NameIdGen, Files, PathResolver, InfoTableBuilder] r =>
|
||||
(Members '[Error JuvixError, NameIdGen, Files, PathResolver, InfoTableBuilder] r) =>
|
||||
Path Abs File ->
|
||||
Text ->
|
||||
Sem r ReplInput
|
||||
replInputFromTextSource fp txt = mapError (JuvixError @ParserError) $ runReplInputParser fp txt
|
||||
|
||||
runReplInputParser ::
|
||||
Members '[Files, NameIdGen, Error ParserError, PathResolver, InfoTableBuilder] r =>
|
||||
(Members '[Files, NameIdGen, Error ParserError, PathResolver, InfoTableBuilder] r) =>
|
||||
Path Abs File ->
|
||||
Text ->
|
||||
Sem r ReplInput
|
||||
@ -117,7 +117,7 @@ runReplInputParser fileName input = do
|
||||
Left err -> throw (ErrMegaparsec (MegaparsecError err))
|
||||
Right r -> return r
|
||||
|
||||
runModuleParser :: Members '[Error ParserError, Files, PathResolver, NameIdGen, InfoTableBuilder] r => Path Abs File -> Text -> Sem r (Either ParserError (Module 'Parsed 'ModuleTop))
|
||||
runModuleParser :: (Members '[Error ParserError, Files, PathResolver, NameIdGen, InfoTableBuilder] r) => Path Abs File -> Text -> Sem r (Either ParserError (Module 'Parsed 'ModuleTop))
|
||||
runModuleParser fileName input = do
|
||||
m <-
|
||||
evalState (Nothing @ParsedPragmas)
|
||||
@ -128,7 +128,7 @@ runModuleParser fileName input = do
|
||||
Right r -> registerModule r $> Right r
|
||||
|
||||
runModuleStdinParser ::
|
||||
Members '[Error ParserError, Files, PathResolver, NameIdGen, InfoTableBuilder] r =>
|
||||
(Members '[Error ParserError, Files, PathResolver, NameIdGen, InfoTableBuilder] r) =>
|
||||
Text ->
|
||||
Sem r (Either ParserError (Module 'Parsed 'ModuleTop))
|
||||
runModuleStdinParser input = do
|
||||
@ -141,7 +141,7 @@ runModuleStdinParser input = do
|
||||
Right r -> registerModule r $> Right r
|
||||
|
||||
runExpressionParser ::
|
||||
Members '[NameIdGen] r =>
|
||||
(Members '[NameIdGen] r) =>
|
||||
Path Abs File ->
|
||||
Text ->
|
||||
Sem r (Either ParserError (ExpressionAtoms 'Parsed))
|
||||
@ -157,7 +157,7 @@ runExpressionParser fileName input = do
|
||||
(_, _, Right r) -> return (Right r)
|
||||
|
||||
-- | The first pipe is optional, and thus we need a `Maybe`. The rest of the elements are guaranted to be given a `Just`.
|
||||
pipeSep1 :: Member InfoTableBuilder r => (Irrelevant (Maybe KeywordRef) -> ParsecS r a) -> ParsecS r (NonEmpty a)
|
||||
pipeSep1 :: (Member InfoTableBuilder r) => (Irrelevant (Maybe KeywordRef) -> ParsecS r a) -> ParsecS r (NonEmpty a)
|
||||
pipeSep1 e = do
|
||||
p <- Irrelevant <$> optional (kw kwPipe)
|
||||
h <- e p
|
||||
@ -186,7 +186,7 @@ topModuleDef = do
|
||||
P.lift (checkPath (m ^. modulePath))
|
||||
return m
|
||||
where
|
||||
checkPath :: Members '[PathResolver, Error ParserError] s => TopModulePath -> Sem s ()
|
||||
checkPath :: (Members '[PathResolver, Error ParserError] s) => TopModulePath -> Sem s ()
|
||||
checkPath path = do
|
||||
let actualPath :: Path Abs File = getLoc path ^. intervalFile
|
||||
mexpectedPath <- expectedModulePath actualPath path
|
||||
@ -201,7 +201,7 @@ topModuleDef = do
|
||||
}
|
||||
)
|
||||
|
||||
replInput :: forall r. Members '[Files, PathResolver, InfoTableBuilder, JudocStash, NameIdGen, Error ParserError, State (Maybe ParsedPragmas)] r => ParsecS r ReplInput
|
||||
replInput :: forall r. (Members '[Files, PathResolver, InfoTableBuilder, JudocStash, NameIdGen, Error ParserError, State (Maybe ParsedPragmas)] r) => ParsecS r ReplInput
|
||||
replInput =
|
||||
P.label "<repl input>" $
|
||||
ReplExpression <$> parseExpressionAtoms
|
||||
@ -238,13 +238,13 @@ usingItem = do
|
||||
_usingAs = snd <$> alias
|
||||
return UsingItem {..}
|
||||
|
||||
hidingItem :: Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r => ParsecS r (HidingItem 'Parsed)
|
||||
hidingItem :: (Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r) => ParsecS r (HidingItem 'Parsed)
|
||||
hidingItem = do
|
||||
_hidingModuleKw <- optional (kw kwModule)
|
||||
_hidingSymbol <- symbol
|
||||
return HidingItem {..}
|
||||
|
||||
phidingList :: Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r => ParsecS r (HidingList 'Parsed)
|
||||
phidingList :: (Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r) => ParsecS r (HidingList 'Parsed)
|
||||
phidingList = do
|
||||
_hidingKw <- Irrelevant <$> kw kwHiding
|
||||
l <- kw delimBraceL
|
||||
@ -256,7 +256,7 @@ phidingList = do
|
||||
..
|
||||
}
|
||||
|
||||
pusingList :: Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r => ParsecS r (UsingList 'Parsed)
|
||||
pusingList :: (Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r) => ParsecS r (UsingList 'Parsed)
|
||||
pusingList = do
|
||||
_usingKw <- Irrelevant <$> kw kwUsing
|
||||
l <- kw delimBraceL
|
||||
@ -278,7 +278,7 @@ topModulePath = mkTopModulePath <$> dottedSymbol
|
||||
infixl 3 <?|>
|
||||
|
||||
-- | Tries the left alternative. If it fails, backtracks and restores the contents of the pragmas and judoc stashes. Then parses the right alternative
|
||||
(<?|>) :: Members '[PragmasStash, JudocStash] r => ParsecS r a -> ParsecS r a -> ParsecS r a
|
||||
(<?|>) :: (Members '[PragmasStash, JudocStash] r) => ParsecS r a -> ParsecS r a -> ParsecS r a
|
||||
l <?|> r = do
|
||||
p <- P.lift (get @(Maybe ParsedPragmas))
|
||||
j <- P.lift (get @(Maybe (Judoc 'Parsed)))
|
||||
@ -288,7 +288,7 @@ l <?|> r = do
|
||||
r
|
||||
P.withRecovery (const recover) (P.try l)
|
||||
|
||||
statement :: Members '[Files, Error ParserError, PathResolver, InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r => ParsecS r (Statement 'Parsed)
|
||||
statement :: (Members '[Files, Error ParserError, PathResolver, InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r) => ParsecS r (Statement 'Parsed)
|
||||
statement = P.label "<top level statement>" $ do
|
||||
optional_ stashJudoc
|
||||
optional_ stashPragmas
|
||||
@ -453,13 +453,13 @@ judocAtom inBlock =
|
||||
judocText_ (P.char ';')
|
||||
return e
|
||||
|
||||
builtinInductive :: Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r => ParsecS r (WithLoc BuiltinInductive)
|
||||
builtinInductive :: (Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r) => ParsecS r (WithLoc BuiltinInductive)
|
||||
builtinInductive = builtinHelper
|
||||
|
||||
builtinFunction :: Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r => ParsecS r (WithLoc BuiltinFunction)
|
||||
builtinFunction :: (Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r) => ParsecS r (WithLoc BuiltinFunction)
|
||||
builtinFunction = builtinHelper
|
||||
|
||||
builtinAxiom :: Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r => ParsecS r (WithLoc BuiltinAxiom)
|
||||
builtinAxiom :: (Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r) => ParsecS r (WithLoc BuiltinAxiom)
|
||||
builtinAxiom = builtinHelper
|
||||
|
||||
builtinHelper ::
|
||||
@ -471,17 +471,17 @@ builtinHelper =
|
||||
| a <- allElements
|
||||
]
|
||||
|
||||
builtinInductiveDef :: Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r => WithLoc BuiltinInductive -> ParsecS r (InductiveDef 'Parsed)
|
||||
builtinInductiveDef :: (Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r) => WithLoc BuiltinInductive -> ParsecS r (InductiveDef 'Parsed)
|
||||
builtinInductiveDef = inductiveDef . Just
|
||||
|
||||
builtinAxiomDef ::
|
||||
Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r =>
|
||||
(Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r) =>
|
||||
WithLoc BuiltinAxiom ->
|
||||
ParsecS r (AxiomDef 'Parsed)
|
||||
builtinAxiomDef = axiomDef . Just
|
||||
|
||||
builtinFunctionDef ::
|
||||
Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r =>
|
||||
(Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r) =>
|
||||
WithLoc BuiltinFunction ->
|
||||
ParsecS r (FunctionDef 'Parsed)
|
||||
builtinFunctionDef = functionDefinition . Just
|
||||
@ -551,7 +551,7 @@ iteratorSyntaxDef _iterSyntaxKw = do
|
||||
-- Import statement
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import_ :: forall r. Members '[Files, PathResolver, InfoTableBuilder, PragmasStash, JudocStash, NameIdGen, Error ParserError] r => ParsecS r (Import 'Parsed)
|
||||
import_ :: forall r. (Members '[Files, PathResolver, InfoTableBuilder, PragmasStash, JudocStash, NameIdGen, Error ParserError] r) => ParsecS r (Import 'Parsed)
|
||||
import_ = do
|
||||
_importKw <- kw kwImport
|
||||
_importModule <- topModulePath
|
||||
@ -573,7 +573,7 @@ withPath' mp a = withPathFile mp (either err a)
|
||||
err :: PathResolverError -> Sem r a
|
||||
err = throw . ErrTopModulePath . TopModulePathError mp
|
||||
|
||||
importedModule :: forall r. Members '[PathResolver, InfoTableBuilder, NameIdGen, Files, Error ParserError] r => TopModulePath -> Sem r ()
|
||||
importedModule :: forall r. (Members '[PathResolver, InfoTableBuilder, NameIdGen, Files, Error ParserError] r) => TopModulePath -> Sem r ()
|
||||
importedModule t = unlessM (moduleVisited t) go
|
||||
where
|
||||
go :: Sem r ()
|
||||
@ -582,7 +582,7 @@ importedModule t = unlessM (moduleVisited t) go
|
||||
txt <- readFile' path
|
||||
eitherM throw (const (return ())) (runModuleParser path txt)
|
||||
|
||||
recordUpdateField :: Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r => ParsecS r (RecordUpdateField 'Parsed)
|
||||
recordUpdateField :: (Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r) => ParsecS r (RecordUpdateField 'Parsed)
|
||||
recordUpdateField = do
|
||||
_fieldUpdateName <- symbol
|
||||
_fieldUpdateAssignKw <- Irrelevant <$> kw kwAssign
|
||||
@ -590,7 +590,7 @@ recordUpdateField = do
|
||||
let _fieldUpdateArgIx = ()
|
||||
return RecordUpdateField {..}
|
||||
|
||||
recordUpdate :: Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r => ParsecS r (RecordUpdate 'Parsed)
|
||||
recordUpdate :: (Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r) => ParsecS r (RecordUpdate 'Parsed)
|
||||
recordUpdate = do
|
||||
_recordUpdateAtKw <- Irrelevant <$> kw kwAt
|
||||
_recordUpdateTypeName <- name
|
||||
@ -601,7 +601,7 @@ recordUpdate = do
|
||||
_recordUpdateExtra = Irrelevant ()
|
||||
return RecordUpdate {..}
|
||||
|
||||
expressionAtom :: Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r => ParsecS r (ExpressionAtom 'Parsed)
|
||||
expressionAtom :: (Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r) => ParsecS r (ExpressionAtom 'Parsed)
|
||||
expressionAtom =
|
||||
P.label "<expression>" $
|
||||
AtomLiteral <$> P.try literal
|
||||
@ -633,7 +633,7 @@ parseExpressionAtoms = do
|
||||
|
||||
iterator ::
|
||||
forall r.
|
||||
Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r =>
|
||||
(Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r) =>
|
||||
ParsecS r (Either (Iterator 'Parsed) (NamedApplication 'Parsed))
|
||||
iterator = do
|
||||
off <- P.getOffset
|
||||
@ -736,7 +736,7 @@ iterator = do
|
||||
|
||||
namedApplication ::
|
||||
forall r.
|
||||
Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r =>
|
||||
(Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r) =>
|
||||
ParsecS r (NamedApplication 'Parsed)
|
||||
namedApplication = P.label "<named application>" $ do
|
||||
(_namedAppName, firstBlockStart) <- P.try $ do
|
||||
@ -751,7 +751,7 @@ namedApplication = P.label "<named application>" $ do
|
||||
|
||||
namedArgument ::
|
||||
forall r.
|
||||
Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r =>
|
||||
(Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r) =>
|
||||
ParsecS r (NamedArgument 'Parsed)
|
||||
namedArgument = do
|
||||
_namedArgName <- symbol
|
||||
@ -761,7 +761,7 @@ namedArgument = do
|
||||
|
||||
argumentBlockStart ::
|
||||
forall r.
|
||||
Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r =>
|
||||
(Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r) =>
|
||||
ParsecS r (KeywordRef, IsImplicit, Symbol, Irrelevant KeywordRef)
|
||||
argumentBlockStart = do
|
||||
(l, impl) <- implicitOpen
|
||||
@ -771,7 +771,7 @@ argumentBlockStart = do
|
||||
|
||||
argumentBlockCont ::
|
||||
forall r.
|
||||
Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r =>
|
||||
(Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r) =>
|
||||
(KeywordRef, IsImplicit, Symbol, Irrelevant KeywordRef) ->
|
||||
ParsecS r (ArgumentBlock 'Parsed)
|
||||
argumentBlockCont (l, _argBlockImplicit, _namedArgName, _namedArgAssignKw) = do
|
||||
@ -784,7 +784,7 @@ argumentBlockCont (l, _argBlockImplicit, _namedArgName, _namedArgAssignKw) = do
|
||||
|
||||
argumentBlock ::
|
||||
forall r.
|
||||
Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r =>
|
||||
(Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r) =>
|
||||
ParsecS r (ArgumentBlock 'Parsed)
|
||||
argumentBlock = do
|
||||
s <- P.try argumentBlockStart
|
||||
@ -793,14 +793,14 @@ argumentBlock = do
|
||||
hole :: (Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r) => ParsecS r (HoleType 'Parsed)
|
||||
hole = kw kwHole
|
||||
|
||||
parseListPattern :: Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r => ParsecS r (ListPattern 'Parsed)
|
||||
parseListPattern :: (Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r) => ParsecS r (ListPattern 'Parsed)
|
||||
parseListPattern = do
|
||||
_listpBracketL <- Irrelevant <$> kw kwBracketL
|
||||
_listpItems <- P.sepBy parsePatternAtoms (kw delimSemicolon)
|
||||
_listpBracketR <- Irrelevant <$> kw kwBracketR
|
||||
return ListPattern {..}
|
||||
|
||||
parseList :: Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r => ParsecS r (List 'Parsed)
|
||||
parseList :: (Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r) => ParsecS r (List 'Parsed)
|
||||
parseList = do
|
||||
_listBracketL <- Irrelevant <$> kw kwBracketL
|
||||
_listItems <- P.sepBy parseExpressionAtoms (kw delimSemicolon)
|
||||
@ -830,7 +830,7 @@ literal = do
|
||||
|
||||
letFunDef ::
|
||||
forall r.
|
||||
Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r =>
|
||||
(Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r) =>
|
||||
ParsecS r (FunctionDef 'Parsed)
|
||||
letFunDef = do
|
||||
optional_ stashPragmas
|
||||
@ -897,7 +897,7 @@ getPragmas = P.lift $ do
|
||||
|
||||
functionDefinition ::
|
||||
forall r.
|
||||
Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r =>
|
||||
(Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r) =>
|
||||
Maybe (WithLoc BuiltinFunction) ->
|
||||
ParsecS r (FunctionDef 'Parsed)
|
||||
functionDefinition _signBuiltin = P.label "<function definition>" $ do
|
||||
@ -953,7 +953,7 @@ functionDefinition _signBuiltin = P.label "<function definition>" $ do
|
||||
parseExpressionAtoms
|
||||
|
||||
axiomDef ::
|
||||
Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r =>
|
||||
(Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r) =>
|
||||
Maybe (WithLoc BuiltinAxiom) ->
|
||||
ParsecS r (AxiomDef 'Parsed)
|
||||
axiomDef _axiomBuiltin = do
|
||||
@ -1027,7 +1027,7 @@ lambda = do
|
||||
-- Data type construction declaration
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
inductiveDef :: Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r => Maybe (WithLoc BuiltinInductive) -> ParsecS r (InductiveDef 'Parsed)
|
||||
inductiveDef :: (Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r) => Maybe (WithLoc BuiltinInductive) -> ParsecS r (InductiveDef 'Parsed)
|
||||
inductiveDef _inductiveBuiltin = do
|
||||
_inductivePositive <- optional (kw kwPositive)
|
||||
_inductiveKw <- Irrelevant <$> kw kwInductive
|
||||
@ -1070,25 +1070,25 @@ inductiveParamsShort = do
|
||||
inductiveParams :: (Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r) => ParsecS r (InductiveParameters 'Parsed)
|
||||
inductiveParams = inductiveParamsLong <|> inductiveParamsShort
|
||||
|
||||
rhsGadt :: Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r => ParsecS r (RhsGadt 'Parsed)
|
||||
rhsGadt :: (Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r) => ParsecS r (RhsGadt 'Parsed)
|
||||
rhsGadt = P.label "<constructor gadt>" $ do
|
||||
_rhsGadtColon <- Irrelevant <$> kw kwColon
|
||||
_rhsGadtType <- parseExpressionAtoms P.<?> "<constructor type>"
|
||||
return RhsGadt {..}
|
||||
|
||||
recordField :: Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r => ParsecS r (RecordField 'Parsed)
|
||||
recordField :: (Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r) => ParsecS r (RecordField 'Parsed)
|
||||
recordField = do
|
||||
_fieldName <- symbol
|
||||
_fieldColon <- Irrelevant <$> kw kwColon
|
||||
_fieldType <- parseExpressionAtoms
|
||||
return RecordField {..}
|
||||
|
||||
rhsAdt :: Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r => ParsecS r (RhsAdt 'Parsed)
|
||||
rhsAdt :: (Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r) => ParsecS r (RhsAdt 'Parsed)
|
||||
rhsAdt = P.label "<constructor arguments>" $ do
|
||||
_rhsAdtArguments <- many atomicExpression
|
||||
return RhsAdt {..}
|
||||
|
||||
rhsRecord :: Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r => ParsecS r (RhsRecord 'Parsed)
|
||||
rhsRecord :: (Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r) => ParsecS r (RhsRecord 'Parsed)
|
||||
rhsRecord = P.label "<constructor record>" $ do
|
||||
l <- kw delimBraceL
|
||||
_rhsRecordFields <- P.sepEndBy1 recordField semicolon
|
||||
@ -1096,13 +1096,13 @@ rhsRecord = P.label "<constructor record>" $ do
|
||||
let _rhsRecordDelim = Irrelevant (l, r)
|
||||
return RhsRecord {..}
|
||||
|
||||
pconstructorRhs :: Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r => ParsecS r (ConstructorRhs 'Parsed)
|
||||
pconstructorRhs :: (Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r) => ParsecS r (ConstructorRhs 'Parsed)
|
||||
pconstructorRhs =
|
||||
ConstructorRhsGadt <$> rhsGadt
|
||||
<|> ConstructorRhsRecord <$> rhsRecord
|
||||
<|> ConstructorRhsAdt <$> rhsAdt
|
||||
|
||||
constructorDef :: Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r => Irrelevant (Maybe KeywordRef) -> ParsecS r (ConstructorDef 'Parsed)
|
||||
constructorDef :: (Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r) => Irrelevant (Maybe KeywordRef) -> ParsecS r (ConstructorDef 'Parsed)
|
||||
constructorDef _constructorPipe = do
|
||||
_constructorDoc <- optional stashJudoc >> getJudoc
|
||||
_constructorPragmas <- optional stashPragmas >> getPragmas
|
||||
@ -1124,12 +1124,12 @@ patternAtomAnon =
|
||||
<|> PatternAtomBraces <$> braces parsePatternAtomsNested
|
||||
<|> PatternAtomList <$> parseListPattern
|
||||
|
||||
patternAtomAt :: Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r => Symbol -> ParsecS r PatternBinding
|
||||
patternAtomAt :: (Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r) => Symbol -> ParsecS r PatternBinding
|
||||
patternAtomAt s = do
|
||||
void (kw kwAt)
|
||||
PatternBinding s <$> patternAtom
|
||||
|
||||
recordPatternItem :: forall r. Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r => ParsecS r (RecordPatternItem 'Parsed)
|
||||
recordPatternItem :: forall r. (Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r) => ParsecS r (RecordPatternItem 'Parsed)
|
||||
recordPatternItem = do
|
||||
f <- symbol
|
||||
RecordPatternItemAssign <$> recordPatternItemAssign f
|
||||
@ -1153,7 +1153,7 @@ recordPatternItem = do
|
||||
_fieldPunField = f
|
||||
}
|
||||
|
||||
patternAtomRecord :: Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r => Name -> ParsecS r (RecordPattern 'Parsed)
|
||||
patternAtomRecord :: (Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r) => Name -> ParsecS r (RecordPattern 'Parsed)
|
||||
patternAtomRecord _recordPatternConstructor = do
|
||||
-- The try is needed to disambiguate from `at` pattern
|
||||
P.try (void (kw kwAt >> kw delimBraceL))
|
||||
|
@ -20,16 +20,16 @@ import Text.Megaparsec.Char.Lexer qualified as L
|
||||
|
||||
type OperatorSym = Text
|
||||
|
||||
judocText :: Members '[InfoTableBuilder] r => ParsecS r a -> ParsecS r a
|
||||
judocText :: (Members '[InfoTableBuilder] r) => ParsecS r a -> ParsecS r a
|
||||
judocText c = do
|
||||
(a, i) <- interval c
|
||||
P.lift (registerJudocText i)
|
||||
return a
|
||||
|
||||
judocText_ :: Members '[InfoTableBuilder] r => ParsecS r a -> ParsecS r ()
|
||||
judocText_ :: (Members '[InfoTableBuilder] r) => ParsecS r a -> ParsecS r ()
|
||||
judocText_ = void . judocText
|
||||
|
||||
space :: forall r. Members '[InfoTableBuilder] r => ParsecS r ()
|
||||
space :: forall r. (Members '[InfoTableBuilder] r) => ParsecS r ()
|
||||
space = space' True >>= mapM_ (P.lift . registerSpaceSpan)
|
||||
|
||||
lexeme :: (Members '[InfoTableBuilder] r) => ParsecS r a -> ParsecS r a
|
||||
@ -68,26 +68,26 @@ bracedString =
|
||||
void (char '\\')
|
||||
char '}'
|
||||
|
||||
string :: Members '[InfoTableBuilder] r => ParsecS r (Text, Interval)
|
||||
string :: (Members '[InfoTableBuilder] r) => ParsecS r (Text, Interval)
|
||||
string = lexemeInterval string'
|
||||
|
||||
judocExampleStart :: ParsecS r ()
|
||||
judocExampleStart = P.chunk Str.judocExample >> hspace_
|
||||
|
||||
judocBlockEnd :: Members '[InfoTableBuilder] r => ParsecS r KeywordRef
|
||||
judocBlockEnd :: (Members '[InfoTableBuilder] r) => ParsecS r KeywordRef
|
||||
judocBlockEnd = kw delimJudocBlockEnd
|
||||
|
||||
judocBlockStart :: Members '[InfoTableBuilder] r => ParsecS r KeywordRef
|
||||
judocBlockStart :: (Members '[InfoTableBuilder] r) => ParsecS r KeywordRef
|
||||
judocBlockStart = kwBare delimJudocBlockStart
|
||||
|
||||
judocStart :: Members '[InfoTableBuilder] r => ParsecS r KeywordRef
|
||||
judocStart :: (Members '[InfoTableBuilder] r) => ParsecS r KeywordRef
|
||||
judocStart = kwBare delimJudocStart <* hspace_
|
||||
|
||||
-- | Does not consume space after it
|
||||
kwBare :: Member InfoTableBuilder r => Keyword -> ParsecS r KeywordRef
|
||||
kwBare :: (Member InfoTableBuilder r) => Keyword -> ParsecS r KeywordRef
|
||||
kwBare k = kw' k >>= P.lift . registerKeyword
|
||||
|
||||
kw :: Member InfoTableBuilder r => Keyword -> ParsecS r KeywordRef
|
||||
kw :: (Member InfoTableBuilder r) => Keyword -> ParsecS r KeywordRef
|
||||
kw = lexeme . kwBare
|
||||
|
||||
-- | Same as @identifier@ but does not consume space after it.
|
||||
|
@ -47,7 +47,7 @@ instance Foldable BinderList where
|
||||
toList :: BinderList a -> [a]
|
||||
toList = (^. blMap)
|
||||
|
||||
instance Show a => Show (BinderList a) where
|
||||
instance (Show a) => Show (BinderList a) where
|
||||
show = S.show . toList
|
||||
|
||||
-- | same as `lookupsSortedRev` but the result is in the same order as the input list.
|
||||
|
@ -34,7 +34,7 @@ getConstructorInfo tag = flip lookupConstructorInfo tag <$> getInfoTable
|
||||
getInductiveInfo :: (Member InfoTableBuilder r) => Symbol -> Sem r InductiveInfo
|
||||
getInductiveInfo sym = flip lookupInductiveInfo sym <$> getInfoTable
|
||||
|
||||
getBuiltinInductiveInfo :: Member InfoTableBuilder r => BuiltinInductive -> Sem r InductiveInfo
|
||||
getBuiltinInductiveInfo :: (Member InfoTableBuilder r) => BuiltinInductive -> Sem r InductiveInfo
|
||||
getBuiltinInductiveInfo b = do
|
||||
tab <- getInfoTable
|
||||
return $ fromJust (lookupBuiltinInductive tab b)
|
||||
@ -228,18 +228,18 @@ declareNatBuiltins = do
|
||||
(tagSuc, "suc", \x -> mkPi' x x, Just BuiltinNatSuc)
|
||||
]
|
||||
|
||||
reserveLiteralIntToNatSymbol :: Member InfoTableBuilder r => Sem r ()
|
||||
reserveLiteralIntToNatSymbol :: (Member InfoTableBuilder r) => Sem r ()
|
||||
reserveLiteralIntToNatSymbol = do
|
||||
sym <- freshSymbol
|
||||
registerLiteralIntToNat sym
|
||||
|
||||
reserveLiteralIntToIntSymbol :: Member InfoTableBuilder r => Sem r ()
|
||||
reserveLiteralIntToIntSymbol :: (Member InfoTableBuilder r) => Sem r ()
|
||||
reserveLiteralIntToIntSymbol = do
|
||||
sym <- freshSymbol
|
||||
registerLiteralIntToInt sym
|
||||
|
||||
-- | Register a function Int -> Nat used to transform literal integers to builtin Nat
|
||||
setupLiteralIntToNat :: forall r. Member InfoTableBuilder r => (Symbol -> Sem r Node) -> Sem r ()
|
||||
setupLiteralIntToNat :: forall r. (Member InfoTableBuilder r) => (Symbol -> Sem r Node) -> Sem r ()
|
||||
setupLiteralIntToNat mkNode = do
|
||||
tab <- getInfoTable
|
||||
whenJust (tab ^. infoLiteralIntToNat) go
|
||||
@ -275,7 +275,7 @@ setupLiteralIntToNat mkNode = do
|
||||
return (maybe mkTypeInteger' (\s -> mkTypeConstr (setInfoName "Nat" mempty) s []) natSymM)
|
||||
|
||||
-- | Register a function Int -> Int used to transform literal integers to builtin Int
|
||||
setupLiteralIntToInt :: forall r. Member InfoTableBuilder r => Sem r Node -> Sem r ()
|
||||
setupLiteralIntToInt :: forall r. (Member InfoTableBuilder r) => Sem r Node -> Sem r ()
|
||||
setupLiteralIntToInt node = do
|
||||
tab <- getInfoTable
|
||||
whenJust (tab ^. infoLiteralIntToInt) go
|
||||
|
@ -43,7 +43,7 @@ comma = symbol ","
|
||||
symbol :: (MonadParsec e Text m) => Text -> m ()
|
||||
symbol = void . lexeme . P.chunk
|
||||
|
||||
transformationLike :: MonadParsec e Text m => m TransformationLikeId
|
||||
transformationLike :: (MonadParsec e Text m) => m TransformationLikeId
|
||||
transformationLike =
|
||||
TransformationId <$> transformation
|
||||
<|> PipelineId <$> parsePipeline
|
||||
@ -97,10 +97,10 @@ transformationText = \case
|
||||
OptPhaseVampIR -> strOptPhaseVampIR
|
||||
OptPhaseMain -> strOptPhaseMain
|
||||
|
||||
parsePipeline :: MonadParsec e Text m => m PipelineId
|
||||
parsePipeline :: (MonadParsec e Text m) => m PipelineId
|
||||
parsePipeline = P.choice [symbol (pipelineText t) $> t | t <- allElements]
|
||||
|
||||
transformation :: MonadParsec e Text m => m TransformationId
|
||||
transformation :: (MonadParsec e Text m) => m TransformationId
|
||||
transformation = P.choice [symbol (transformationText t) $> t | t <- allElements]
|
||||
|
||||
allStrings :: [Text]
|
||||
|
@ -338,7 +338,7 @@ makeLenses ''TypeConstr'
|
||||
makeLenses ''Dynamic'
|
||||
makeLenses ''LetItem'
|
||||
|
||||
instance Eq ty => Eq (Binder' ty) where
|
||||
instance (Eq ty) => Eq (Binder' ty) where
|
||||
(==) = eqOn (^. binderType)
|
||||
|
||||
instance Eq (Var' i) where
|
||||
|
@ -10,33 +10,33 @@ import Juvix.Compiler.Core.Transformation
|
||||
import Juvix.Compiler.Pipeline.EntryPoint (EntryPoint)
|
||||
|
||||
-- | Perform transformations on Core necessary for efficient evaluation
|
||||
toEval' :: Members '[Error JuvixError, Reader CoreOptions] r => InfoTable -> Sem r InfoTable
|
||||
toEval' :: (Members '[Error JuvixError, Reader CoreOptions] r) => InfoTable -> Sem r InfoTable
|
||||
toEval' = applyTransformations toEvalTransformations
|
||||
|
||||
toTypechecked :: Members '[Error JuvixError, Reader EntryPoint] r => InfoTable -> Sem r InfoTable
|
||||
toTypechecked :: (Members '[Error JuvixError, Reader EntryPoint] r) => InfoTable -> Sem r InfoTable
|
||||
toTypechecked = mapReader fromEntryPoint . applyTransformations toTypecheckTransformations
|
||||
|
||||
toEval :: Members '[Error JuvixError, Reader EntryPoint] r => InfoTable -> Sem r InfoTable
|
||||
toEval :: (Members '[Error JuvixError, Reader EntryPoint] r) => InfoTable -> Sem r InfoTable
|
||||
toEval = mapReader fromEntryPoint . applyTransformations toEvalTransformations
|
||||
|
||||
-- | Perform transformations on Core necessary before the translation to
|
||||
-- Core.Stripped
|
||||
toStripped' :: Members '[Error JuvixError, Reader CoreOptions] r => InfoTable -> Sem r InfoTable
|
||||
toStripped' :: (Members '[Error JuvixError, Reader CoreOptions] r) => InfoTable -> Sem r InfoTable
|
||||
toStripped' = applyTransformations toStrippedTransformations
|
||||
|
||||
toStripped :: Members '[Error JuvixError, Reader EntryPoint] r => InfoTable -> Sem r InfoTable
|
||||
toStripped :: (Members '[Error JuvixError, Reader EntryPoint] r) => InfoTable -> Sem r InfoTable
|
||||
toStripped = mapReader fromEntryPoint . applyTransformations toStrippedTransformations
|
||||
|
||||
-- | Perform transformations on Core necessary before the translation to GEB
|
||||
toGeb' :: Members '[Error JuvixError, Reader CoreOptions] r => InfoTable -> Sem r InfoTable
|
||||
toGeb' :: (Members '[Error JuvixError, Reader CoreOptions] r) => InfoTable -> Sem r InfoTable
|
||||
toGeb' = applyTransformations toGebTransformations
|
||||
|
||||
toGeb :: Members '[Error JuvixError, Reader EntryPoint] r => InfoTable -> Sem r InfoTable
|
||||
toGeb :: (Members '[Error JuvixError, Reader EntryPoint] r) => InfoTable -> Sem r InfoTable
|
||||
toGeb = mapReader fromEntryPoint . applyTransformations toGebTransformations
|
||||
|
||||
-- | Perform transformations on Core necessary before the translation to VampIR
|
||||
toVampIR' :: Members '[Error JuvixError, Reader CoreOptions] r => InfoTable -> Sem r InfoTable
|
||||
toVampIR' :: (Members '[Error JuvixError, Reader CoreOptions] r) => InfoTable -> Sem r InfoTable
|
||||
toVampIR' = applyTransformations toVampIRTransformations
|
||||
|
||||
toVampIR :: Members '[Error JuvixError, Reader EntryPoint] r => InfoTable -> Sem r InfoTable
|
||||
toVampIR :: (Members '[Error JuvixError, Reader EntryPoint] r) => InfoTable -> Sem r InfoTable
|
||||
toVampIR = mapReader fromEntryPoint . applyTransformations toVampIRTransformations
|
||||
|
@ -70,7 +70,7 @@ instance PrettyCode Primitive where
|
||||
ppName :: NameKind -> Text -> Sem r (Doc Ann)
|
||||
ppName kind name = return $ annotate (AnnKind kind) (pretty name)
|
||||
|
||||
ppIdentName :: Member (Reader Options) r => Text -> Symbol -> Sem r (Doc Ann)
|
||||
ppIdentName :: (Member (Reader Options) r) => Text -> Symbol -> Sem r (Doc Ann)
|
||||
ppIdentName name sym = do
|
||||
showIds <- asks (^. optShowIdentIds)
|
||||
let name' = if showIds then name <> "!" <> prettyText sym else name
|
||||
@ -157,7 +157,7 @@ instance (PrettyCode a) => PrettyCode (Binder' a) where
|
||||
ty' <- ppCode ty
|
||||
return (parens (pretty name' <+> kwColon <+> ty'))
|
||||
|
||||
ppWithType :: Member (Reader Options) r => Doc Ann -> Type -> Sem r (Doc Ann)
|
||||
ppWithType :: (Member (Reader Options) r) => Doc Ann -> Type -> Sem r (Doc Ann)
|
||||
ppWithType d = \case
|
||||
NDyn {} ->
|
||||
return d
|
||||
@ -172,12 +172,12 @@ ppNameTyped kn name mty = do
|
||||
Nothing -> return n
|
||||
Just ty -> return $ parens (n <+> kwColon <+> ty)
|
||||
|
||||
ppType :: Member (Reader Options) r => Type -> Sem r (Maybe (Doc Ann))
|
||||
ppType :: (Member (Reader Options) r) => Type -> Sem r (Maybe (Doc Ann))
|
||||
ppType = \case
|
||||
NDyn {} -> return Nothing
|
||||
ty -> Just <$> ppCode ty
|
||||
|
||||
ppTypeAnnot :: Member (Reader Options) r => Type -> Sem r (Doc Ann)
|
||||
ppTypeAnnot :: (Member (Reader Options) r) => Type -> Sem r (Doc Ann)
|
||||
ppTypeAnnot = \case
|
||||
NDyn {} ->
|
||||
return mempty
|
||||
@ -225,7 +225,7 @@ ppCodeCase' branchBinderNames branchBinderTypes branchTagNames Case {..} =
|
||||
let bss = bracesIndent $ align $ concatWith (\a b -> a <> kwSemicolon <> line <> b) bs''
|
||||
return $ kwCase <+> v <+> kwOf <+> bss
|
||||
|
||||
instance PrettyCode a => PrettyCode (If' i a) where
|
||||
instance (PrettyCode a) => PrettyCode (If' i a) where
|
||||
ppCode If {..} = do
|
||||
v <- ppCode _ifValue
|
||||
l <- ppCode _ifTrue
|
||||
@ -310,7 +310,7 @@ instance PrettyCode Lambda where
|
||||
return (lam <> oneLineOrNext b)
|
||||
|
||||
instance PrettyCode Bottom where
|
||||
ppCode :: Member (Reader Options) r => Bottom -> Sem r (Doc Ann)
|
||||
ppCode :: (Member (Reader Options) r) => Bottom -> Sem r (Doc Ann)
|
||||
ppCode Bottom {..} = do
|
||||
ty' <- ppCode _bottomType
|
||||
return (parens (kwBottom <+> kwColon <+> ty'))
|
||||
@ -400,7 +400,7 @@ instance PrettyCode Stripped.Type where
|
||||
Stripped.TyApp x -> ppCode x
|
||||
Stripped.TyFun x -> ppCode x
|
||||
|
||||
ppTypeStripped :: Member (Reader Options) r => Stripped.Type -> Sem r (Maybe (Doc Ann))
|
||||
ppTypeStripped :: (Member (Reader Options) r) => Stripped.Type -> Sem r (Maybe (Doc Ann))
|
||||
ppTypeStripped = \case
|
||||
Stripped.TyDynamic -> return Nothing
|
||||
ty -> Just <$> ppCode ty
|
||||
@ -579,7 +579,7 @@ instance (PrettyCode a) => PrettyCode [a] where
|
||||
-- printing values
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
goBinary :: Member (Reader Options) r => Bool -> Fixity -> Doc Ann -> [Value] -> Sem r (Doc Ann)
|
||||
goBinary :: (Member (Reader Options) r) => Bool -> Fixity -> Doc Ann -> [Value] -> Sem r (Doc Ann)
|
||||
goBinary isComma fixity name = \case
|
||||
[] -> return (parens name)
|
||||
[arg] -> do
|
||||
@ -596,7 +596,7 @@ goBinary isComma fixity name = \case
|
||||
_ ->
|
||||
impossible
|
||||
|
||||
goUnary :: Member (Reader Options) r => Fixity -> Doc Ann -> [Value] -> Sem r (Doc Ann)
|
||||
goUnary :: (Member (Reader Options) r) => Fixity -> Doc Ann -> [Value] -> Sem r (Doc Ann)
|
||||
goUnary fixity name = \case
|
||||
[] -> return (parens name)
|
||||
[arg] -> do
|
||||
@ -627,7 +627,7 @@ instance PrettyCode Value where
|
||||
ValueFun -> return "<function>"
|
||||
ValueType -> return "<type>"
|
||||
|
||||
ppValueSequence :: Member (Reader Options) r => [Value] -> Sem r (Doc Ann)
|
||||
ppValueSequence :: (Member (Reader Options) r) => [Value] -> Sem r (Doc Ann)
|
||||
ppValueSequence vs = hsep <$> mapM (ppRightExpression appFixity) vs
|
||||
|
||||
docValueSequence :: [Value] -> Doc Ann
|
||||
|
@ -45,7 +45,7 @@ import Juvix.Compiler.Core.Transformation.RemoveTypeArgs
|
||||
import Juvix.Compiler.Core.Transformation.TopEtaExpand
|
||||
import Juvix.Compiler.Core.Transformation.UnrollRecursion
|
||||
|
||||
applyTransformations :: forall r. Members '[Error JuvixError, Reader CoreOptions] r => [TransformationId] -> InfoTable -> Sem r InfoTable
|
||||
applyTransformations :: forall r. (Members '[Error JuvixError, Reader CoreOptions] r) => [TransformationId] -> InfoTable -> Sem r InfoTable
|
||||
applyTransformations ts tbl = foldM (flip appTrans) tbl ts
|
||||
where
|
||||
appTrans :: TransformationId -> InfoTable -> Sem r InfoTable
|
||||
|
@ -11,22 +11,22 @@ import Juvix.Compiler.Core.Data.InfoTableBuilder
|
||||
import Juvix.Compiler.Core.Language
|
||||
import Juvix.Compiler.Core.Options
|
||||
|
||||
mapIdentsM :: Monad m => (IdentifierInfo -> m IdentifierInfo) -> InfoTable -> m InfoTable
|
||||
mapIdentsM :: (Monad m) => (IdentifierInfo -> m IdentifierInfo) -> InfoTable -> m InfoTable
|
||||
mapIdentsM = overM infoIdentifiers . mapM
|
||||
|
||||
mapInductivesM :: Monad m => (InductiveInfo -> m InductiveInfo) -> InfoTable -> m InfoTable
|
||||
mapInductivesM :: (Monad m) => (InductiveInfo -> m InductiveInfo) -> InfoTable -> m InfoTable
|
||||
mapInductivesM = overM infoInductives . mapM
|
||||
|
||||
mapConstructorsM :: Monad m => (ConstructorInfo -> m ConstructorInfo) -> InfoTable -> m InfoTable
|
||||
mapConstructorsM :: (Monad m) => (ConstructorInfo -> m ConstructorInfo) -> InfoTable -> m InfoTable
|
||||
mapConstructorsM = overM infoConstructors . mapM
|
||||
|
||||
mapAxiomsM :: Monad m => (AxiomInfo -> m AxiomInfo) -> InfoTable -> m InfoTable
|
||||
mapAxiomsM :: (Monad m) => (AxiomInfo -> m AxiomInfo) -> InfoTable -> m InfoTable
|
||||
mapAxiomsM = overM infoAxioms . mapM
|
||||
|
||||
mapNodesM :: Monad m => (Node -> m Node) -> InfoTable -> m InfoTable
|
||||
mapNodesM :: (Monad m) => (Node -> m Node) -> InfoTable -> m InfoTable
|
||||
mapNodesM = overM identContext . mapM
|
||||
|
||||
mapAllNodesM :: Monad m => (Node -> m Node) -> InfoTable -> m InfoTable
|
||||
mapAllNodesM :: (Monad m) => (Node -> m Node) -> InfoTable -> m InfoTable
|
||||
mapAllNodesM f tab =
|
||||
mapNodesM f tab
|
||||
>>= mapAxiomsM (overM axiomType f)
|
||||
@ -87,12 +87,12 @@ mapAllNodes f tab =
|
||||
convertAxiom :: AxiomInfo -> AxiomInfo
|
||||
convertAxiom = over axiomType f
|
||||
|
||||
withOptimizationLevel :: Member (Reader CoreOptions) r => Int -> (InfoTable -> Sem r InfoTable) -> InfoTable -> Sem r InfoTable
|
||||
withOptimizationLevel :: (Member (Reader CoreOptions) r) => Int -> (InfoTable -> Sem r InfoTable) -> InfoTable -> Sem r InfoTable
|
||||
withOptimizationLevel n f tab = do
|
||||
l <- asks (^. optOptimizationLevel)
|
||||
if
|
||||
| l >= n -> f tab
|
||||
| otherwise -> return tab
|
||||
|
||||
withOptimizationLevel' :: Member (Reader CoreOptions) r => InfoTable -> Int -> (InfoTable -> Sem r InfoTable) -> Sem r InfoTable
|
||||
withOptimizationLevel' :: (Member (Reader CoreOptions) r) => InfoTable -> Int -> (InfoTable -> Sem r InfoTable) -> Sem r InfoTable
|
||||
withOptimizationLevel' tab n f = withOptimizationLevel n f tab
|
||||
|
@ -20,7 +20,7 @@ dynamicTypeError node loc =
|
||||
_coreErrorLoc = fromMaybe defaultLoc loc
|
||||
}
|
||||
|
||||
axiomError :: Members '[Error CoreError, InfoTableBuilder] r => Symbol -> Maybe Location -> Sem r a
|
||||
axiomError :: (Members '[Error CoreError, InfoTableBuilder] r) => Symbol -> Maybe Location -> Sem r a
|
||||
axiomError sym loc = do
|
||||
tbl <- getInfoTable
|
||||
let nameTxt = identName tbl sym
|
||||
@ -45,7 +45,7 @@ defaultLoc = singletonInterval (mkInitialLoc mockFile)
|
||||
mockFile :: Path Abs File
|
||||
mockFile = $(mkAbsFile "/core-check")
|
||||
|
||||
checkBuiltins :: forall r. Member (Error CoreError) r => Bool -> Node -> Sem r Node
|
||||
checkBuiltins :: forall r. (Member (Error CoreError) r) => Bool -> Node -> Sem r Node
|
||||
checkBuiltins allowUntypedFail = dmapRM go
|
||||
where
|
||||
go :: Node -> Sem r Recur
|
||||
@ -73,7 +73,7 @@ checkBuiltins allowUntypedFail = dmapRM go
|
||||
-- | Checks that the root of the node is not `Bottom`. Currently the only way we
|
||||
-- create `Bottom` is when translating axioms that are not builtin. Hence it is
|
||||
-- enough to check the root only.
|
||||
checkNoAxioms :: forall r. Member (Error CoreError) r => InfoTable -> Sem r ()
|
||||
checkNoAxioms :: forall r. (Member (Error CoreError) r) => InfoTable -> Sem r ()
|
||||
checkNoAxioms = void . mapT' checkNodeNoAxiom
|
||||
where
|
||||
checkNodeNoAxiom :: Symbol -> Node -> Sem (InfoTableBuilder ': r) Node
|
||||
@ -81,7 +81,7 @@ checkNoAxioms = void . mapT' checkNodeNoAxiom
|
||||
NBot {} -> axiomError sym (getNodeLocation n)
|
||||
_ -> return n
|
||||
|
||||
checkNoIO :: forall r. Member (Error CoreError) r => Node -> Sem r Node
|
||||
checkNoIO :: forall r. (Member (Error CoreError) r) => Node -> Sem r Node
|
||||
checkNoIO = dmapM go
|
||||
where
|
||||
go :: Node -> Sem r Node
|
||||
@ -95,7 +95,7 @@ checkNoIO = dmapM go
|
||||
_ -> return node
|
||||
_ -> return node
|
||||
|
||||
checkTypes :: forall r. Member (Error CoreError) r => Bool -> InfoTable -> Node -> Sem r Node
|
||||
checkTypes :: forall r. (Member (Error CoreError) r) => Bool -> InfoTable -> Node -> Sem r Node
|
||||
checkTypes allowPolymorphism tab = dmapM go
|
||||
where
|
||||
go :: Node -> Sem r Node
|
||||
@ -122,7 +122,7 @@ checkTypes allowPolymorphism tab = dmapM go
|
||||
}
|
||||
_ -> return node
|
||||
|
||||
checkNoRecursiveTypes :: forall r. Member (Error CoreError) r => InfoTable -> Sem r ()
|
||||
checkNoRecursiveTypes :: forall r. (Member (Error CoreError) r) => InfoTable -> Sem r ()
|
||||
checkNoRecursiveTypes tab =
|
||||
when (isCyclic (createTypeDependencyInfo tab)) $
|
||||
throw
|
||||
@ -132,7 +132,7 @@ checkNoRecursiveTypes tab =
|
||||
_coreErrorLoc = defaultLoc
|
||||
}
|
||||
|
||||
checkMainExists :: forall r. Member (Error CoreError) r => InfoTable -> Sem r ()
|
||||
checkMainExists :: forall r. (Member (Error CoreError) r) => InfoTable -> Sem r ()
|
||||
checkMainExists tab =
|
||||
when (isNothing (tab ^. infoMain)) $
|
||||
throw
|
||||
|
@ -6,7 +6,7 @@ import Juvix.Compiler.Core.Transformation.Base
|
||||
import Juvix.Compiler.Core.Transformation.Check.Base
|
||||
import Juvix.Data.PPOutput
|
||||
|
||||
checkExec :: forall r. Member (Error CoreError) r => InfoTable -> Sem r InfoTable
|
||||
checkExec :: forall r. (Member (Error CoreError) r) => InfoTable -> Sem r InfoTable
|
||||
checkExec tab = do
|
||||
checkNoAxioms tab
|
||||
case tab ^. infoMain of
|
||||
|
@ -4,7 +4,7 @@ import Juvix.Compiler.Core.Error
|
||||
import Juvix.Compiler.Core.Transformation.Base
|
||||
import Juvix.Compiler.Core.Transformation.Check.Base
|
||||
|
||||
checkGeb :: forall r. Member (Error CoreError) r => InfoTable -> Sem r InfoTable
|
||||
checkGeb :: forall r. (Member (Error CoreError) r) => InfoTable -> Sem r InfoTable
|
||||
checkGeb tab =
|
||||
checkMainExists tab
|
||||
>> checkNoRecursiveTypes tab
|
||||
|
@ -6,7 +6,7 @@ import Juvix.Compiler.Core.Transformation.Base
|
||||
import Juvix.Compiler.Core.Transformation.Check.Base
|
||||
import Juvix.Data.PPOutput
|
||||
|
||||
checkVampIR :: forall r. Member (Error CoreError) r => InfoTable -> Sem r InfoTable
|
||||
checkVampIR :: forall r. (Member (Error CoreError) r) => InfoTable -> Sem r InfoTable
|
||||
checkVampIR tab =
|
||||
checkMainExists tab
|
||||
>> checkMainType
|
||||
|
@ -13,15 +13,15 @@ import Juvix.Compiler.Core.Pretty
|
||||
import Juvix.Compiler.Core.Transformation.Base
|
||||
import Juvix.Compiler.Core.Transformation.ComputeTypeInfo (computeNodeType)
|
||||
|
||||
lambdaLiftBinder :: Members '[Reader OnlyLetRec, InfoTableBuilder] r => BinderList Binder -> Binder -> Sem r Binder
|
||||
lambdaLiftBinder :: (Members '[Reader OnlyLetRec, InfoTableBuilder] r) => BinderList Binder -> Binder -> Sem r Binder
|
||||
lambdaLiftBinder bl = traverseOf binderType (lambdaLiftNode bl)
|
||||
|
||||
type OnlyLetRec = Bool
|
||||
|
||||
lambdaLiftNode' :: forall r. Member InfoTableBuilder r => Bool -> BinderList Binder -> Node -> Sem r Node
|
||||
lambdaLiftNode' :: forall r. (Member InfoTableBuilder r) => Bool -> BinderList Binder -> Node -> Sem r Node
|
||||
lambdaLiftNode' onlyLetRec bl top = runReader onlyLetRec $ lambdaLiftNode bl top
|
||||
|
||||
lambdaLiftNode :: forall r. Members '[Reader OnlyLetRec, InfoTableBuilder] r => BinderList Binder -> Node -> Sem r Node
|
||||
lambdaLiftNode :: forall r. (Members '[Reader OnlyLetRec, InfoTableBuilder] r) => BinderList Binder -> Node -> Sem r Node
|
||||
lambdaLiftNode aboveBl top =
|
||||
let topArgs :: [LambdaLhs]
|
||||
(topArgs, body) = unfoldLambdas top
|
||||
|
@ -37,7 +37,7 @@ mkLetsTable l = HashMap.fromList [(i ^. indexedThing . itemSymbol, i) | i <- l]
|
||||
letHoisting :: InfoTable -> InfoTable
|
||||
letHoisting = run . mapT' (const letHoist)
|
||||
|
||||
letHoist :: forall r. Members '[InfoTableBuilder] r => Node -> Sem r Node
|
||||
letHoist :: forall r. (Members '[InfoTableBuilder] r) => Node -> Sem r Node
|
||||
letHoist n = do
|
||||
let (topLambdas, body) = unfoldLambdas n
|
||||
(l, body') <- runReader @[Symbol] [] (runOutputList @LItem (removeLets body))
|
||||
@ -51,7 +51,7 @@ letHoist n = do
|
||||
return (reLambdas topLambdas body'')
|
||||
|
||||
-- | Removes every Let node and replaces references to it with a unique symbol.
|
||||
removeLets :: forall r. Members '[InfoTableBuilder, Output LItem, Reader [Symbol]] r => Node -> Sem r Node
|
||||
removeLets :: forall r. (Members '[InfoTableBuilder, Output LItem, Reader [Symbol]] r) => Node -> Sem r Node
|
||||
removeLets = go mempty
|
||||
where
|
||||
go :: BinderList Binder -> Node -> Sem r Node
|
||||
@ -106,13 +106,13 @@ isLetHoisted =
|
||||
checkBody n = isJust . run . runFail $ do
|
||||
k <- peelLets n
|
||||
noLets k
|
||||
peelLets :: Members '[Fail] r => Node -> Sem r Node
|
||||
peelLets :: (Members '[Fail] r) => Node -> Sem r Node
|
||||
peelLets = \case
|
||||
NLet Let {..} -> do
|
||||
noLets (_letItem ^. letItemValue)
|
||||
peelLets _letBody
|
||||
n -> return n
|
||||
noLets :: forall r. Members '[Fail] r => Node -> Sem r ()
|
||||
noLets :: forall r. (Members '[Fail] r) => Node -> Sem r ()
|
||||
noLets = walk go
|
||||
where
|
||||
go :: Node -> Sem r ()
|
||||
|
@ -28,12 +28,12 @@ type PatternMatrix = [PatternRow]
|
||||
-- | Compiles pattern matches (`Match` nodes) to decision trees built up from
|
||||
-- `Case` nodes. The algorithm is based on the paper: Luc Maranget, "Compiling
|
||||
-- Pattern Matching to Good Decision Trees", ML'08.
|
||||
matchToCase :: Members '[Error CoreError, Reader CoreOptions] r => InfoTable -> Sem r InfoTable
|
||||
matchToCase :: (Members '[Error CoreError, Reader CoreOptions] r) => InfoTable -> Sem r InfoTable
|
||||
matchToCase tab = runReader tab $ mapAllNodesM (rmapM goMatchToCase) tab
|
||||
|
||||
goMatchToCase ::
|
||||
forall r.
|
||||
Members '[Error CoreError, Reader CoreOptions, Reader InfoTable] r =>
|
||||
(Members '[Error CoreError, Reader CoreOptions, Reader InfoTable] r) =>
|
||||
([BinderChange] -> Node -> Sem r Node) ->
|
||||
Node ->
|
||||
Sem r Node
|
||||
|
@ -16,7 +16,7 @@ mkShiftedPis' lhs rhs = foldl' go (shift (length lhs) rhs) (reverse (indexFrom 0
|
||||
go :: Type -> Indexed Type -> Type
|
||||
go t (Indexed i a) = mkPi' (shift i a) t
|
||||
|
||||
matchToCaseNode :: forall r. Member InfoTableBuilder r => Node -> Sem r Node
|
||||
matchToCaseNode :: forall r. (Member InfoTableBuilder r) => Node -> Sem r Node
|
||||
matchToCaseNode n = case n of
|
||||
NMatch m -> do
|
||||
let branches = m ^. matchBranches
|
||||
@ -114,7 +114,7 @@ shiftEmbedded wrappingLevel m = umapN go
|
||||
-- This is because we have added 3 binders around the body, 6 auxillary binders,
|
||||
-- 1 binder for the lambda surrounding the case and 1 binder for the fail
|
||||
-- branch.
|
||||
compileMatchBranch :: forall r. Members '[InfoTableBuilder] r => Indexed MatchBranch -> Sem r Node
|
||||
compileMatchBranch :: forall r. (Members '[InfoTableBuilder] r) => Indexed MatchBranch -> Sem r Node
|
||||
compileMatchBranch (Indexed branchNum br) = do
|
||||
compiledBranch <- runReader initState (combineCompiledPatterns (map (compilePattern 0 branchNum patternsNum) patterns))
|
||||
return (mkShiftedLambdas branchNum shiftedPatternTypes ((compiledBranch ^. compiledPatMkNode) (wrapBody (compiledBranch ^. compiledPatBinders))))
|
||||
@ -195,7 +195,7 @@ extractOriginalBinders vs = updateBinders $ fmap getBinder <$> reverse (filterIn
|
||||
-- refers to its argument by index (n - 2) and so on. This is the purpose of the indexedPatterns and setting the CompileStateNode.
|
||||
--
|
||||
-- The patterns are then evaluated and combined from left to right in the list .
|
||||
combineCompiledPatterns :: forall r. Member (Reader CompileState) r => [Sem ((Reader CompileStateNode) ': r) CompiledPattern] -> Sem r CompiledPattern
|
||||
combineCompiledPatterns :: forall r. (Member (Reader CompileState) r) => [Sem ((Reader CompileStateNode) ': r) CompiledPattern] -> Sem r CompiledPattern
|
||||
combineCompiledPatterns ps = go indexedPatterns
|
||||
where
|
||||
indexedPatterns :: [Indexed (Sem ((Reader CompileStateNode) ': r) CompiledPattern)]
|
||||
@ -223,7 +223,7 @@ combineCompiledPatterns ps = go indexedPatterns
|
||||
-- (wildcard, binder or constructor) introduces an auxiliary binder.
|
||||
-- The arguments are then compiled recursively using a new CompileState context.
|
||||
-- The default case points to the next branch pattern.
|
||||
compilePattern :: forall r. Members '[Reader CompileState, Reader CompileStateNode, InfoTableBuilder] r => Int -> Int -> Int -> Pattern -> Sem r CompiledPattern
|
||||
compilePattern :: forall r. (Members '[Reader CompileState, Reader CompileStateNode, InfoTableBuilder] r) => Int -> Int -> Int -> Pattern -> Sem r CompiledPattern
|
||||
compilePattern baseShift branchNum numPatterns = \case
|
||||
PatWildcard w -> do
|
||||
auxPatternsNum <- length . filter isAuxiliaryBinder <$> asks (^. compileStateCompiledPattern . compiledPatBinders)
|
||||
@ -302,10 +302,10 @@ compilePattern baseShift branchNum numPatterns = \case
|
||||
failNode :: [Type] -> Node
|
||||
failNode tys = mkShiftedLambdas 0 tys (mkBuiltinApp' OpFail [mkConstant' (ConstString "Non-exhaustive patterns")])
|
||||
|
||||
mkUniqueBinder' :: Member InfoTableBuilder r => Text -> Node -> Sem r Binder
|
||||
mkUniqueBinder' :: (Member InfoTableBuilder r) => Text -> Node -> Sem r Binder
|
||||
mkUniqueBinder' name ty = mkUniqueBinder name Nothing ty
|
||||
|
||||
mkUniqueBinder :: Member InfoTableBuilder r => Text -> Maybe Location -> Node -> Sem r Binder
|
||||
mkUniqueBinder :: (Member InfoTableBuilder r) => Text -> Maybe Location -> Node -> Sem r Binder
|
||||
mkUniqueBinder name loc ty = do
|
||||
sym <- freshSymbol
|
||||
return
|
||||
@ -317,7 +317,7 @@ mkUniqueBinder name loc ty = do
|
||||
|
||||
-- | The default node in a case expression.
|
||||
-- It points to the next branch above.
|
||||
defaultNode' :: Member (Reader CompileState) r => Int -> Sem r Node
|
||||
defaultNode' :: (Member (Reader CompileState) r) => Int -> Sem r Node
|
||||
defaultNode' numMatchValues = do
|
||||
numBindersAbove <- asks (^. compileStateBindersAbove)
|
||||
return
|
||||
|
@ -50,16 +50,16 @@ makeLenses ''CompiledPattern
|
||||
makeLenses ''CompileState
|
||||
makeLenses ''CompileStateNode
|
||||
|
||||
addBindersAbove :: Member (Reader CompileState) r => Int -> Sem r CompiledPattern -> Sem r CompiledPattern
|
||||
addBindersAbove :: (Member (Reader CompileState) r) => Int -> Sem r CompiledPattern -> Sem r CompiledPattern
|
||||
addBindersAbove bindersNum = local (over compileStateBindersAbove (+ bindersNum))
|
||||
|
||||
incBindersAbove :: Member (Reader CompileState) r => Sem r CompiledPattern -> Sem r CompiledPattern
|
||||
incBindersAbove :: (Member (Reader CompileState) r) => Sem r CompiledPattern -> Sem r CompiledPattern
|
||||
incBindersAbove = addBindersAbove 1
|
||||
|
||||
resetCompiledPattern :: Member (Reader CompileState) r => Sem r CompiledPattern -> Sem r CompiledPattern
|
||||
resetCompiledPattern :: (Member (Reader CompileState) r) => Sem r CompiledPattern -> Sem r CompiledPattern
|
||||
resetCompiledPattern = local (set compileStateCompiledPattern mempty)
|
||||
|
||||
resetCurrentNode :: Member (Reader CompileStateNode) r => Sem r CompiledPattern -> Sem r CompiledPattern
|
||||
resetCurrentNode :: (Member (Reader CompileStateNode) r) => Sem r CompiledPattern -> Sem r CompiledPattern
|
||||
resetCurrentNode = local (set compileStateNodeCurrent (mkVar' 0))
|
||||
|
||||
instance Semigroup CompiledPattern where
|
||||
|
@ -51,7 +51,7 @@ convertNode inlineDepth recSyms tab = dmap go
|
||||
inlining' :: Int -> HashSet Symbol -> InfoTable -> InfoTable
|
||||
inlining' inliningDepth recSyms tab = mapT (const (convertNode inliningDepth recSyms tab)) tab
|
||||
|
||||
inlining :: Member (Reader CoreOptions) r => InfoTable -> Sem r InfoTable
|
||||
inlining :: (Member (Reader CoreOptions) r) => InfoTable -> Sem r InfoTable
|
||||
inlining tab = do
|
||||
d <- asks (^. optInliningDepth)
|
||||
return $ inlining' d (recursiveIdents tab) tab
|
||||
|
@ -5,7 +5,7 @@ import Juvix.Compiler.Core.Transformation.Base
|
||||
import Juvix.Compiler.Core.Transformation.Optimize.LambdaFolding
|
||||
import Juvix.Compiler.Core.Transformation.Optimize.LetFolding
|
||||
|
||||
optimize :: Member (Reader CoreOptions) r => InfoTable -> Sem r InfoTable
|
||||
optimize :: (Member (Reader CoreOptions) r) => InfoTable -> Sem r InfoTable
|
||||
optimize =
|
||||
withOptimizationLevel 1 $
|
||||
return . letFolding . lambdaFolding
|
||||
|
@ -7,7 +7,7 @@ import Juvix.Compiler.Core.Transformation.Optimize.LetFolding
|
||||
import Juvix.Compiler.Core.Transformation.Optimize.Phase.Main qualified as Main
|
||||
import Juvix.Compiler.Core.Transformation.TopEtaExpand
|
||||
|
||||
optimize :: Member (Reader CoreOptions) r => InfoTable -> Sem r InfoTable
|
||||
optimize :: (Member (Reader CoreOptions) r) => InfoTable -> Sem r InfoTable
|
||||
optimize tab = do
|
||||
opts <- ask
|
||||
withOptimizationLevel' tab 1 $
|
||||
|
@ -4,5 +4,5 @@ import Juvix.Compiler.Core.Options
|
||||
import Juvix.Compiler.Core.Transformation.Base
|
||||
import Juvix.Compiler.Core.Transformation.Optimize.Phase.Main qualified as Main
|
||||
|
||||
optimize :: Member (Reader CoreOptions) r => InfoTable -> Sem r InfoTable
|
||||
optimize :: (Member (Reader CoreOptions) r) => InfoTable -> Sem r InfoTable
|
||||
optimize = withOptimizationLevel 1 Main.optimize
|
||||
|
@ -26,7 +26,7 @@ optimize' CoreOptions {..} tab =
|
||||
. letFolding
|
||||
$ tab
|
||||
|
||||
optimize :: Member (Reader CoreOptions) r => InfoTable -> Sem r InfoTable
|
||||
optimize :: (Member (Reader CoreOptions) r) => InfoTable -> Sem r InfoTable
|
||||
optimize tab = do
|
||||
opts <- ask
|
||||
return $ optimize' opts tab
|
||||
|
@ -7,7 +7,7 @@ import Juvix.Compiler.Core.Transformation.Optimize.LambdaFolding
|
||||
import Juvix.Compiler.Core.Transformation.Optimize.LetFolding
|
||||
import Juvix.Compiler.Core.Transformation.Optimize.SimplifyIfs
|
||||
|
||||
optimize :: Member (Reader CoreOptions) r => InfoTable -> Sem r InfoTable
|
||||
optimize :: (Member (Reader CoreOptions) r) => InfoTable -> Sem r InfoTable
|
||||
optimize =
|
||||
withOptimizationLevel 1 $
|
||||
return . letFolding . simplifyIfs . caseCallLifting . letFolding . lambdaFolding
|
||||
|
@ -27,7 +27,7 @@ isArgSpecializable tab sym argNum = run $ execState True $ dmapNRM go body
|
||||
(lams, body) = unfoldLambdas nodeSym
|
||||
n = length lams
|
||||
|
||||
go :: Member (State Bool) r => Level -> Node -> Sem r Recur
|
||||
go :: (Member (State Bool) r) => Level -> Node -> Sem r Recur
|
||||
go lvl node = case node of
|
||||
NApp {} ->
|
||||
let (h, args) = unfoldApps' node
|
||||
@ -50,7 +50,7 @@ isArgSpecializable tab sym argNum = run $ execState True $ dmapNRM go body
|
||||
return $ End node
|
||||
_ -> return $ Recur node
|
||||
|
||||
convertNode :: forall r. Member InfoTableBuilder r => InfoTable -> Node -> Sem r Node
|
||||
convertNode :: forall r. (Member InfoTableBuilder r) => InfoTable -> Node -> Sem r Node
|
||||
convertNode tab = dmapLRM go
|
||||
where
|
||||
go :: BinderList Binder -> Node -> Sem r Recur
|
||||
|
@ -8,7 +8,7 @@ import Juvix.Compiler.Core.Info.TypeInfo (setNodeType)
|
||||
import Juvix.Compiler.Core.Options
|
||||
import Juvix.Compiler.Core.Transformation.Base
|
||||
|
||||
unrollRecursion :: Member (Reader CoreOptions) r => InfoTable -> Sem r InfoTable
|
||||
unrollRecursion :: (Member (Reader CoreOptions) r) => InfoTable -> Sem r InfoTable
|
||||
unrollRecursion tab = do
|
||||
(mp, tab') <-
|
||||
runState @(HashMap Symbol Symbol) mempty $
|
||||
@ -30,19 +30,19 @@ unrollRecursion tab = do
|
||||
adjustMain :: Maybe Symbol -> Maybe Symbol
|
||||
adjustMain = fmap $ \sym -> fromMaybe sym (HashMap.lookup sym mp)
|
||||
|
||||
goSCC :: Members '[InfoTableBuilder, State (HashMap Symbol Symbol), Reader CoreOptions] r => SCC Symbol -> Sem r ()
|
||||
goSCC :: (Members '[InfoTableBuilder, State (HashMap Symbol Symbol), Reader CoreOptions] r) => SCC Symbol -> Sem r ()
|
||||
goSCC = \case
|
||||
CyclicSCC syms -> unrollSCC syms
|
||||
AcyclicSCC _ -> return ()
|
||||
|
||||
unrollSCC :: Members '[InfoTableBuilder, State (HashMap Symbol Symbol), Reader CoreOptions] r => [Symbol] -> Sem r ()
|
||||
unrollSCC :: (Members '[InfoTableBuilder, State (HashMap Symbol Symbol), Reader CoreOptions] r) => [Symbol] -> Sem r ()
|
||||
unrollSCC syms = do
|
||||
unrollLimit <- computeUnrollLimit
|
||||
freshSyms <- genSyms unrollLimit syms
|
||||
forM_ syms (unroll unrollLimit freshSyms)
|
||||
modify (\mp -> foldr (mapSymbol unrollLimit freshSyms) mp syms)
|
||||
where
|
||||
computeUnrollLimit :: Member (Reader CoreOptions) r => Sem r Int
|
||||
computeUnrollLimit :: (Member (Reader CoreOptions) r) => Sem r Int
|
||||
computeUnrollLimit = do
|
||||
defaultUnrollLimit <- asks (^. optUnrollLimit)
|
||||
let lims = nonEmpty (mapMaybe go syms)
|
||||
@ -56,7 +56,7 @@ unrollRecursion tab = do
|
||||
mapSymbol :: Int -> HashMap (Indexed Symbol) Symbol -> Symbol -> HashMap Symbol Symbol -> HashMap Symbol Symbol
|
||||
mapSymbol unrollLimit freshSyms sym = HashMap.insert sym (fromJust $ HashMap.lookup (Indexed unrollLimit sym) freshSyms)
|
||||
|
||||
genSyms :: forall r. Member InfoTableBuilder r => Int -> [Symbol] -> Sem r (HashMap (Indexed Symbol) Symbol)
|
||||
genSyms :: forall r. (Member InfoTableBuilder r) => Int -> [Symbol] -> Sem r (HashMap (Indexed Symbol) Symbol)
|
||||
genSyms unrollLimit = foldr go (return mempty)
|
||||
where
|
||||
go :: Symbol -> Sem r (HashMap (Indexed Symbol) Symbol) -> Sem r (HashMap (Indexed Symbol) Symbol)
|
||||
@ -68,7 +68,7 @@ unrollRecursion tab = do
|
||||
sym' <- freshSymbol
|
||||
return $ HashMap.insert (Indexed limit sym) sym' mp
|
||||
|
||||
unroll :: forall r. Member InfoTableBuilder r => Int -> HashMap (Indexed Symbol) Symbol -> Symbol -> Sem r ()
|
||||
unroll :: forall r. (Member InfoTableBuilder r) => Int -> HashMap (Indexed Symbol) Symbol -> Symbol -> Sem r ()
|
||||
unroll unrollLimit freshSyms sym = do
|
||||
forM_ [0 .. unrollLimit] goUnroll
|
||||
removeSymbol sym
|
||||
|
@ -62,7 +62,7 @@ fromInternal i = do
|
||||
_coreResultInternalTypedResult = i
|
||||
}
|
||||
where
|
||||
f :: Members '[InfoTableBuilder, Reader InternalTyped.TypesTable, State InternalTyped.FunctionsTable, State InternalTyped.FunctionsTable] r => Sem r ()
|
||||
f :: (Members '[InfoTableBuilder, Reader InternalTyped.TypesTable, State InternalTyped.FunctionsTable, State InternalTyped.FunctionsTable] r) => Sem r ()
|
||||
f = do
|
||||
reserveLiteralIntToNatSymbol
|
||||
reserveLiteralIntToIntSymbol
|
||||
@ -89,14 +89,14 @@ fromInternalExpression res exp = do
|
||||
|
||||
goModule ::
|
||||
forall r.
|
||||
Members '[InfoTableBuilder, Reader InternalTyped.TypesTable, State InternalTyped.FunctionsTable, Reader Internal.InfoTable, MVisit] r =>
|
||||
(Members '[InfoTableBuilder, Reader InternalTyped.TypesTable, State InternalTyped.FunctionsTable, Reader Internal.InfoTable, MVisit] r) =>
|
||||
Internal.Module ->
|
||||
Sem r ()
|
||||
goModule = visit . Internal.ModuleIndex
|
||||
|
||||
goModuleNoVisit ::
|
||||
forall r.
|
||||
Members '[InfoTableBuilder, Reader InternalTyped.TypesTable, State InternalTyped.FunctionsTable, Reader Internal.InfoTable, MVisit] r =>
|
||||
(Members '[InfoTableBuilder, Reader InternalTyped.TypesTable, State InternalTyped.FunctionsTable, Reader Internal.InfoTable, MVisit] r) =>
|
||||
Internal.ModuleIndex ->
|
||||
Sem r ()
|
||||
goModuleNoVisit (Internal.ModuleIndex m) = do
|
||||
@ -834,7 +834,7 @@ addPatternVariableNames p lvl vars =
|
||||
|
||||
goIden ::
|
||||
forall r.
|
||||
Members '[InfoTableBuilder, Reader InternalTyped.TypesTable, State InternalTyped.FunctionsTable, Reader Internal.InfoTable, Reader IndexTable] r =>
|
||||
(Members '[InfoTableBuilder, Reader InternalTyped.TypesTable, State InternalTyped.FunctionsTable, Reader Internal.InfoTable, Reader IndexTable] r) =>
|
||||
Internal.Iden ->
|
||||
Sem r Node
|
||||
goIden i = do
|
||||
|
@ -7,7 +7,7 @@ import Juvix.Compiler.Core.Language
|
||||
|
||||
-- | Returns the node representing a function Int -> Int that transforms literal
|
||||
-- integers to builtin Int.
|
||||
literalIntToIntNode :: Member InfoTableBuilder r => Sem r Node
|
||||
literalIntToIntNode :: (Member InfoTableBuilder r) => Sem r Node
|
||||
literalIntToIntNode = do
|
||||
tab <- getInfoTable
|
||||
let intToNatSymM = tab ^. infoLiteralIntToNat
|
||||
|
@ -8,7 +8,7 @@ import Juvix.Compiler.Core.Language
|
||||
-- | Returns the node representing a function Int -> Nat that is used to transform
|
||||
-- literal integers to builtin Nat. The symbol representing the literalIntToNat function is passed
|
||||
-- so that it can be called recusively.
|
||||
literalIntToNatNode :: Member InfoTableBuilder r => Symbol -> Sem r Node
|
||||
literalIntToNatNode :: (Member InfoTableBuilder r) => Symbol -> Sem r Node
|
||||
literalIntToNatNode sym = do
|
||||
tab <- getInfoTable
|
||||
let tagZeroM = (^. constructorTag) <$> lookupBuiltinConstructor tab BuiltinNatZero
|
||||
|
@ -14,7 +14,7 @@ makeLenses ''IndexTable
|
||||
initIndexTable :: IndexTable
|
||||
initIndexTable = IndexTable 0 mempty
|
||||
|
||||
localAddName :: Member (Reader IndexTable) r => Name -> Sem r a -> Sem r a
|
||||
localAddName :: (Member (Reader IndexTable) r) => Name -> Sem r a -> Sem r a
|
||||
localAddName n = localAddNames [n]
|
||||
|
||||
localAddNames :: forall r a. (Member (Reader IndexTable) r) => [Name] -> Sem r a -> Sem r a
|
||||
@ -34,5 +34,5 @@ localAddNames names s = do
|
||||
. over indexTableVarsNum (+ len)
|
||||
)
|
||||
|
||||
underBinders :: Members '[Reader IndexTable] r => Int -> Sem r a -> Sem r a
|
||||
underBinders :: (Members '[Reader IndexTable] r) => Int -> Sem r a -> Sem r a
|
||||
underBinders nBinders = local (over indexTableVarsNum (+ nBinders))
|
||||
|
@ -617,7 +617,7 @@ exprUniverse = do
|
||||
exprDynamic :: ParsecS r Type
|
||||
exprDynamic = kw kwAny $> mkDynamic'
|
||||
|
||||
exprBottom :: Members '[InfoTableBuilder] r => ParsecS r Node
|
||||
exprBottom :: (Members '[InfoTableBuilder] r) => ParsecS r Node
|
||||
exprBottom = do
|
||||
(ty, loc) <- interval $ do
|
||||
kw kwBottom
|
||||
|
@ -26,10 +26,10 @@ import Juvix.Prelude
|
||||
|
||||
type MCache = Cache ModuleIndex InfoTable
|
||||
|
||||
buildTable :: Foldable f => f Module -> InfoTable
|
||||
buildTable :: (Foldable f) => f Module -> InfoTable
|
||||
buildTable = run . evalCache (computeTable True) mempty . getMany
|
||||
|
||||
buildTable' :: Foldable f => Bool -> f Module -> InfoTable
|
||||
buildTable' :: (Foldable f) => Bool -> f Module -> InfoTable
|
||||
buildTable' recurIntoImports = run . evalCache (computeTable recurIntoImports) mempty . getMany
|
||||
|
||||
buildTableShallow :: Module -> InfoTable
|
||||
@ -50,7 +50,7 @@ extendWithReplExpression e =
|
||||
)
|
||||
)
|
||||
|
||||
letFunctionDefs :: Data from => from -> [FunctionDef]
|
||||
letFunctionDefs :: (Data from) => from -> [FunctionDef]
|
||||
letFunctionDefs e =
|
||||
concat
|
||||
[ concatMap (toList . flattenClause) _letClauses
|
||||
@ -62,7 +62,7 @@ letFunctionDefs e =
|
||||
LetFunDef f -> pure f
|
||||
LetMutualBlock (MutualBlockLet fs) -> fs
|
||||
|
||||
computeTable :: forall r. Members '[MCache] r => Bool -> ModuleIndex -> Sem r InfoTable
|
||||
computeTable :: forall r. (Members '[MCache] r) => Bool -> ModuleIndex -> Sem r InfoTable
|
||||
computeTable recurIntoImports (ModuleIndex m) = compute
|
||||
where
|
||||
compute :: Sem r InfoTable
|
||||
@ -124,7 +124,7 @@ computeTable recurIntoImports (ModuleIndex m) = compute
|
||||
ss :: [Statement]
|
||||
ss = m ^. moduleBody . moduleStatements
|
||||
|
||||
lookupConstructor :: forall r. Member (Reader InfoTable) r => Name -> Sem r ConstructorInfo
|
||||
lookupConstructor :: forall r. (Member (Reader InfoTable) r) => Name -> Sem r ConstructorInfo
|
||||
lookupConstructor f = do
|
||||
err <- impossibleErr
|
||||
HashMap.lookupDefault err f <$> asks (^. infoConstructors)
|
||||
@ -143,7 +143,7 @@ lookupConstructor f = do
|
||||
lookupConstructorArgTypes :: (Member (Reader InfoTable) r) => Name -> Sem r ([VarName], [Expression])
|
||||
lookupConstructorArgTypes = fmap constructorArgTypes . lookupConstructor
|
||||
|
||||
lookupInductive :: forall r. Member (Reader InfoTable) r => InductiveName -> Sem r InductiveInfo
|
||||
lookupInductive :: forall r. (Member (Reader InfoTable) r) => InductiveName -> Sem r InductiveInfo
|
||||
lookupInductive f = do
|
||||
err <- impossibleErr
|
||||
HashMap.lookupDefault err f <$> asks (^. infoInductives)
|
||||
@ -159,7 +159,7 @@ lookupInductive f = do
|
||||
<> "The registered inductives are: "
|
||||
<> ppTrace (HashMap.keys tbl)
|
||||
|
||||
lookupFunction :: forall r. Member (Reader InfoTable) r => Name -> Sem r FunctionInfo
|
||||
lookupFunction :: forall r. (Member (Reader InfoTable) r) => Name -> Sem r FunctionInfo
|
||||
lookupFunction f = do
|
||||
err <- impossibleErr
|
||||
HashMap.lookupDefault err f <$> asks (^. infoFunctions)
|
||||
@ -178,7 +178,7 @@ lookupFunction f = do
|
||||
lookupAxiom :: (Member (Reader InfoTable) r) => Name -> Sem r AxiomInfo
|
||||
lookupAxiom f = HashMap.lookupDefault impossible f <$> asks (^. infoAxioms)
|
||||
|
||||
lookupInductiveType :: Member (Reader InfoTable) r => Name -> Sem r Expression
|
||||
lookupInductiveType :: (Member (Reader InfoTable) r) => Name -> Sem r Expression
|
||||
lookupInductiveType v = do
|
||||
info <- lookupInductive v
|
||||
let ps = info ^. inductiveInfoDef . inductiveParameters
|
||||
@ -190,20 +190,20 @@ lookupInductiveType v = do
|
||||
where
|
||||
uni = smallUniverseE (getLoc v)
|
||||
|
||||
lookupConstructorType :: Member (Reader InfoTable) r => ConstrName -> Sem r Expression
|
||||
lookupConstructorType :: (Member (Reader InfoTable) r) => ConstrName -> Sem r Expression
|
||||
lookupConstructorType = fmap constructorType . lookupConstructor
|
||||
|
||||
lookupConstructorReturnType :: Member (Reader InfoTable) r => ConstrName -> Sem r Expression
|
||||
lookupConstructorReturnType :: (Member (Reader InfoTable) r) => ConstrName -> Sem r Expression
|
||||
lookupConstructorReturnType = fmap constructorReturnType . lookupConstructor
|
||||
|
||||
getAxiomBuiltinInfo :: Member (Reader InfoTable) r => Name -> Sem r (Maybe BuiltinAxiom)
|
||||
getAxiomBuiltinInfo :: (Member (Reader InfoTable) r) => Name -> Sem r (Maybe BuiltinAxiom)
|
||||
getAxiomBuiltinInfo n = do
|
||||
maybeAxiomInfo <- HashMap.lookup n <$> asks (^. infoAxioms)
|
||||
return $ case maybeAxiomInfo of
|
||||
Just axiomInfo -> axiomInfo ^. axiomInfoDef . axiomBuiltin
|
||||
Nothing -> Nothing
|
||||
|
||||
getFunctionBuiltinInfo :: Member (Reader InfoTable) r => Name -> Sem r (Maybe BuiltinFunction)
|
||||
getFunctionBuiltinInfo :: (Member (Reader InfoTable) r) => Name -> Sem r (Maybe BuiltinFunction)
|
||||
getFunctionBuiltinInfo n = do
|
||||
maybeFunInfo <- HashMap.lookup n <$> asks (^. infoFunctions)
|
||||
return $ case maybeFunInfo of
|
||||
|
@ -38,7 +38,7 @@ varFromHole h =
|
||||
where
|
||||
pp = "_ω" <> prettyText (h ^. holeId)
|
||||
|
||||
varFromWildcard :: Members '[NameIdGen] r => Wildcard -> Sem r VarName
|
||||
varFromWildcard :: (Members '[NameIdGen] r) => Wildcard -> Sem r VarName
|
||||
varFromWildcard w = do
|
||||
_nameId <- freshNameId
|
||||
let _nameText :: Text = "_ω" <> prettyText _nameId
|
||||
|
@ -270,7 +270,7 @@ patternVariables f p = case p of
|
||||
goApp :: Traversal' ConstructorApp VarName
|
||||
goApp g = traverseOf constrAppParameters (traverse (patternArgVariables g))
|
||||
|
||||
inductiveTypeVarsAssoc :: Foldable f => InductiveDef -> f a -> HashMap VarName a
|
||||
inductiveTypeVarsAssoc :: (Foldable f) => InductiveDef -> f a -> HashMap VarName a
|
||||
inductiveTypeVarsAssoc def l
|
||||
| length vars < n = impossible
|
||||
| otherwise = HashMap.fromList (zip vars (toList l))
|
||||
@ -532,7 +532,7 @@ infixl 9 @@
|
||||
(@@) :: (IsExpression a, IsExpression b) => a -> b -> Expression
|
||||
a @@ b = toExpression (Application (toExpression a) (toExpression b) Explicit)
|
||||
|
||||
freshVar :: Member NameIdGen r => Interval -> Text -> Sem r VarName
|
||||
freshVar :: (Member NameIdGen r) => Interval -> Text -> Sem r VarName
|
||||
freshVar _nameLoc n = do
|
||||
uid <- freshNameId
|
||||
return
|
||||
@ -545,10 +545,10 @@ freshVar _nameLoc n = do
|
||||
_nameLoc
|
||||
}
|
||||
|
||||
freshHole :: Members '[NameIdGen] r => Interval -> Sem r Hole
|
||||
freshHole :: (Members '[NameIdGen] r) => Interval -> Sem r Hole
|
||||
freshHole l = mkHole l <$> freshNameId
|
||||
|
||||
mkFreshHole :: Members '[NameIdGen] r => Interval -> Sem r Expression
|
||||
mkFreshHole :: (Members '[NameIdGen] r) => Interval -> Sem r Expression
|
||||
mkFreshHole l = ExpressionHole <$> freshHole l
|
||||
|
||||
matchExpressions ::
|
||||
@ -664,7 +664,7 @@ isSmallUniverse' = \case
|
||||
ExpressionUniverse {} -> True
|
||||
_ -> False
|
||||
|
||||
allTypeSignatures :: Data a => a -> [Expression]
|
||||
allTypeSignatures :: (Data a) => a -> [Expression]
|
||||
allTypeSignatures a =
|
||||
[f ^. funDefType | f@FunctionDef {} <- universeBi a]
|
||||
<> [f ^. axiomType | f@AxiomDef {} <- universeBi a]
|
||||
@ -709,11 +709,11 @@ patternArgFromVar i v =
|
||||
}
|
||||
|
||||
-- | Given `mkPair`, returns (mkPair a b, [a, b])
|
||||
genConstructorPattern :: Members '[NameIdGen] r => Interval -> ConstructorInfo -> Sem r (PatternArg, [VarName])
|
||||
genConstructorPattern :: (Members '[NameIdGen] r) => Interval -> ConstructorInfo -> Sem r (PatternArg, [VarName])
|
||||
genConstructorPattern loc info = genConstructorPattern' loc (info ^. constructorInfoName) (length (snd (constructorArgTypes info)))
|
||||
|
||||
-- | Given `mkPair`, returns (mkPair a b, [a, b])
|
||||
genConstructorPattern' :: Members '[NameIdGen] r => Interval -> Name -> Int -> Sem r (PatternArg, [VarName])
|
||||
genConstructorPattern' :: (Members '[NameIdGen] r) => Interval -> Name -> Int -> Sem r (PatternArg, [VarName])
|
||||
genConstructorPattern' loc cname cargs = do
|
||||
vars <- mapM (freshVar loc) (Stream.take cargs allWords)
|
||||
return (mkConstructorVarPattern cname vars, vars)
|
||||
@ -736,7 +736,7 @@ mkConstructorVarPattern c vars =
|
||||
-- allowed at the moment).
|
||||
genFieldProjection ::
|
||||
forall r.
|
||||
Members '[NameIdGen] r =>
|
||||
(Members '[NameIdGen] r) =>
|
||||
FunctionName ->
|
||||
ConstructorInfo ->
|
||||
Int ->
|
||||
|
@ -74,29 +74,29 @@ checkStartNode n = do
|
||||
(HashSet.member (n ^. nameId) tab)
|
||||
(addStartNode n)
|
||||
|
||||
goModuleNoVisited :: forall r. Members '[Reader ExportsTable, State DependencyGraph, State StartNodes, Visit ModuleIndex] r => ModuleIndex -> Sem r ()
|
||||
goModuleNoVisited :: forall r. (Members '[Reader ExportsTable, State DependencyGraph, State StartNodes, Visit ModuleIndex] r) => ModuleIndex -> Sem r ()
|
||||
goModuleNoVisited (ModuleIndex m) = do
|
||||
checkStartNode (m ^. moduleName)
|
||||
let b = m ^. moduleBody
|
||||
mapM_ (goStatement (m ^. moduleName)) (b ^. moduleStatements)
|
||||
mapM_ goImport (b ^. moduleImports)
|
||||
|
||||
goImport :: Members '[Reader ExportsTable, State DependencyGraph, State StartNodes, Visit ModuleIndex] r => Import -> Sem r ()
|
||||
goImport :: (Members '[Reader ExportsTable, State DependencyGraph, State StartNodes, Visit ModuleIndex] r) => Import -> Sem r ()
|
||||
goImport (Import m) = visit m
|
||||
|
||||
-- | Ignores includes
|
||||
goPreModule :: Members '[Reader ExportsTable, State DependencyGraph, State StartNodes] r => PreModule -> Sem r ()
|
||||
goPreModule :: (Members '[Reader ExportsTable, State DependencyGraph, State StartNodes] r) => PreModule -> Sem r ()
|
||||
goPreModule m = do
|
||||
checkStartNode (m ^. moduleName)
|
||||
let b = m ^. moduleBody
|
||||
mapM_ (goPreStatement (m ^. moduleName)) (b ^. moduleStatements)
|
||||
|
||||
goStatement :: forall r. Members '[Reader ExportsTable, State DependencyGraph, State StartNodes] r => Name -> Statement -> Sem r ()
|
||||
goStatement :: forall r. (Members '[Reader ExportsTable, State DependencyGraph, State StartNodes] r) => Name -> Statement -> Sem r ()
|
||||
goStatement parentModule = \case
|
||||
StatementAxiom ax -> goAxiom parentModule ax
|
||||
StatementMutual f -> goMutual parentModule f
|
||||
|
||||
goMutual :: forall r. Members '[Reader ExportsTable, State DependencyGraph, State StartNodes] r => Name -> MutualBlock -> Sem r ()
|
||||
goMutual :: forall r. (Members '[Reader ExportsTable, State DependencyGraph, State StartNodes] r) => Name -> MutualBlock -> Sem r ()
|
||||
goMutual parentModule (MutualBlock s) = mapM_ go s
|
||||
where
|
||||
go :: MutualStatement -> Sem r ()
|
||||
@ -106,7 +106,7 @@ goMutual parentModule (MutualBlock s) = mapM_ go s
|
||||
|
||||
goPreLetStatement ::
|
||||
forall r.
|
||||
Members '[Reader ExportsTable, State DependencyGraph, State StartNodes] r =>
|
||||
(Members '[Reader ExportsTable, State DependencyGraph, State StartNodes] r) =>
|
||||
PreLetStatement ->
|
||||
Sem r ()
|
||||
goPreLetStatement = \case
|
||||
@ -114,19 +114,19 @@ goPreLetStatement = \case
|
||||
|
||||
-- | Declarations in a module depend on the module, not the other way round (a
|
||||
-- module is reachable if at least one of the declarations in it is reachable)
|
||||
goPreStatement :: forall r. Members '[Reader ExportsTable, State DependencyGraph, State StartNodes] r => Name -> PreStatement -> Sem r ()
|
||||
goPreStatement :: forall r. (Members '[Reader ExportsTable, State DependencyGraph, State StartNodes] r) => Name -> PreStatement -> Sem r ()
|
||||
goPreStatement parentModule = \case
|
||||
PreAxiomDef ax -> goAxiom parentModule ax
|
||||
PreFunctionDef f -> goTopFunctionDef parentModule f
|
||||
PreInductiveDef i -> goInductive parentModule i
|
||||
|
||||
goAxiom :: forall r. Members '[Reader ExportsTable, State DependencyGraph, State StartNodes] r => Name -> AxiomDef -> Sem r ()
|
||||
goAxiom :: forall r. (Members '[Reader ExportsTable, State DependencyGraph, State StartNodes] r) => Name -> AxiomDef -> Sem r ()
|
||||
goAxiom parentModule ax = do
|
||||
checkStartNode (ax ^. axiomName)
|
||||
addEdge (ax ^. axiomName) parentModule
|
||||
goExpression (Just (ax ^. axiomName)) (ax ^. axiomType)
|
||||
|
||||
goInductive :: forall r. Members '[Reader ExportsTable, State DependencyGraph, State StartNodes] r => Name -> InductiveDef -> Sem r ()
|
||||
goInductive :: forall r. (Members '[Reader ExportsTable, State DependencyGraph, State StartNodes] r) => Name -> InductiveDef -> Sem r ()
|
||||
goInductive parentModule i = do
|
||||
checkStartNode (i ^. inductiveName)
|
||||
checkBuiltinInductiveStartNode i
|
||||
@ -137,7 +137,7 @@ goInductive parentModule i = do
|
||||
|
||||
-- BuiltinBool and BuiltinNat are required by the Internal to Core translation
|
||||
-- when translating literal integers to Nats.
|
||||
checkBuiltinInductiveStartNode :: forall r. Member (State StartNodes) r => InductiveDef -> Sem r ()
|
||||
checkBuiltinInductiveStartNode :: forall r. (Member (State StartNodes) r) => InductiveDef -> Sem r ()
|
||||
checkBuiltinInductiveStartNode i = whenJust (i ^. inductiveBuiltin) go
|
||||
where
|
||||
go :: BuiltinInductive -> Sem r ()
|
||||
|
@ -19,8 +19,8 @@ ppOutDefault = mkAnsiText . PPOutput . doc defaultOptions
|
||||
ppOut :: (CanonicalProjection a Options, PrettyCode c) => a -> c -> AnsiText
|
||||
ppOut o = mkAnsiText . PPOutput . doc (project o)
|
||||
|
||||
ppTrace :: PrettyCode c => c -> Text
|
||||
ppTrace :: (PrettyCode c) => c -> Text
|
||||
ppTrace = Ansi.renderStrict . reAnnotateS stylize . layoutPretty defaultLayoutOptions . doc traceOptions
|
||||
|
||||
ppPrint :: PrettyCode c => c -> Text
|
||||
ppPrint :: (PrettyCode c) => c -> Text
|
||||
ppPrint = renderStrict . toTextStream . ppOutDefault
|
||||
|
@ -104,7 +104,7 @@ ppMutual = \case
|
||||
return (kwMutual <+> braces (line <> indent' b' <> line))
|
||||
|
||||
instance PrettyCode LetClause where
|
||||
ppCode :: forall r. Member (Reader Options) r => LetClause -> Sem r (Doc Ann)
|
||||
ppCode :: forall r. (Member (Reader Options) r) => LetClause -> Sem r (Doc Ann)
|
||||
ppCode = \case
|
||||
LetFunDef f -> ppCode f
|
||||
LetMutualBlock b -> ppMutual (b ^. mutualLet)
|
||||
@ -155,7 +155,7 @@ instance PrettyCode Lambda where
|
||||
lambdaType' <- mapM ppCode _lambdaType
|
||||
return $ kwLambda <+> (fmap (kwColon <+>) lambdaType') <?+> braces lambdaClauses'
|
||||
|
||||
instance PrettyCode a => PrettyCode (WithLoc a) where
|
||||
instance (PrettyCode a) => PrettyCode (WithLoc a) where
|
||||
ppCode = ppCode . (^. withLocParam)
|
||||
|
||||
instance PrettyCode FunctionParameter where
|
||||
@ -290,7 +290,7 @@ instance PrettyCode ModuleBody where
|
||||
return (vsep includes <> line <> line <> vsep2 everything)
|
||||
|
||||
instance PrettyCode Module where
|
||||
ppCode :: Member (Reader Options) r => Module -> Sem r (Doc Ann)
|
||||
ppCode :: (Member (Reader Options) r) => Module -> Sem r (Doc Ann)
|
||||
ppCode m = do
|
||||
name' <- ppCode (m ^. moduleName)
|
||||
body' <- ppCode (m ^. moduleBody)
|
||||
@ -355,7 +355,7 @@ ppCodeAtom c = do
|
||||
p' <- ppCode c
|
||||
return $ if isAtomic c then p' else parens p'
|
||||
|
||||
instance PrettyCode a => PrettyCode (Maybe a) where
|
||||
instance (PrettyCode a) => PrettyCode (Maybe a) where
|
||||
ppCode = \case
|
||||
Nothing -> return "Nothing"
|
||||
Just p -> ("Just" <+>) <$> ppCode p
|
||||
@ -369,10 +369,10 @@ instance (PrettyCode a, PrettyCode b) => PrettyCode (a, b) where
|
||||
y' <- ppCode y
|
||||
return $ tuple [x', y']
|
||||
|
||||
instance PrettyCode a => PrettyCode [a] where
|
||||
instance (PrettyCode a) => PrettyCode [a] where
|
||||
ppCode x = do
|
||||
cs <- mapM ppCode (toList x)
|
||||
return $ encloseSep "[" "]" ", " cs
|
||||
|
||||
instance PrettyCode a => PrettyCode (NonEmpty a) where
|
||||
instance (PrettyCode a) => PrettyCode (NonEmpty a) where
|
||||
ppCode x = ppCode (toList x)
|
||||
|
@ -35,7 +35,7 @@ unsupported :: Text -> a
|
||||
unsupported msg = error $ msg <> "Scoped to Internal: not yet supported"
|
||||
|
||||
fromConcrete ::
|
||||
Members '[Reader EntryPoint, Error JuvixError, Builtins, NameIdGen] r =>
|
||||
(Members '[Reader EntryPoint, Error JuvixError, Builtins, NameIdGen] r) =>
|
||||
Scoper.ScoperResult ->
|
||||
Sem r InternalResult
|
||||
fromConcrete _resultScoper =
|
||||
@ -56,7 +56,7 @@ fromConcrete _resultScoper =
|
||||
|
||||
-- | `StatementInclude`s are no included in the result
|
||||
buildMutualBlocks ::
|
||||
Members '[Reader Internal.NameDependencyInfo] r =>
|
||||
(Members '[Reader Internal.NameDependencyInfo] r) =>
|
||||
[Internal.PreStatement] ->
|
||||
Sem r [SCC Internal.PreStatement]
|
||||
buildMutualBlocks ss = do
|
||||
@ -131,7 +131,7 @@ fromConcreteExpression :: (Members '[Builtins, Error JuvixError, NameIdGen] r) =
|
||||
fromConcreteExpression = mapError (JuvixError @ScoperError) . runReader @Pragmas mempty . goExpression
|
||||
|
||||
fromConcreteImport ::
|
||||
Members '[Reader ExportsTable, Error JuvixError, NameIdGen, Builtins, MCache] r =>
|
||||
(Members '[Reader ExportsTable, Error JuvixError, NameIdGen, Builtins, MCache] r) =>
|
||||
Scoper.Import 'Scoped ->
|
||||
Sem r Internal.Import
|
||||
fromConcreteImport =
|
||||
@ -140,25 +140,25 @@ fromConcreteImport =
|
||||
. goImport
|
||||
|
||||
fromConcreteOpenImport ::
|
||||
Members '[Reader ExportsTable, Error JuvixError, NameIdGen, Builtins, MCache] r =>
|
||||
(Members '[Reader ExportsTable, Error JuvixError, NameIdGen, Builtins, MCache] r) =>
|
||||
Scoper.OpenModule 'Scoped ->
|
||||
Sem r (Maybe Internal.Import)
|
||||
fromConcreteOpenImport = mapError (JuvixError @ScoperError) . runReader @Pragmas mempty . goOpenModule'
|
||||
|
||||
goLocalModule ::
|
||||
Members '[Error ScoperError, Builtins, NameIdGen, Reader Pragmas, State ConstructorInfos] r =>
|
||||
(Members '[Error ScoperError, Builtins, NameIdGen, Reader Pragmas, State ConstructorInfos] r) =>
|
||||
Module 'Scoped 'ModuleLocal ->
|
||||
Sem r [Internal.PreStatement]
|
||||
goLocalModule = concatMapM goAxiomInductive . (^. moduleBody)
|
||||
|
||||
goTopModule ::
|
||||
Members '[Reader ExportsTable, Error ScoperError, Builtins, NameIdGen, Reader Pragmas, MCache] r =>
|
||||
(Members '[Reader ExportsTable, Error ScoperError, Builtins, NameIdGen, Reader Pragmas, MCache] r) =>
|
||||
Module 'Scoped 'ModuleTop ->
|
||||
Sem r Internal.Module
|
||||
goTopModule = cacheGet . ModuleIndex
|
||||
|
||||
goModuleNoCache ::
|
||||
Members '[Reader EntryPoint, Reader ExportsTable, Error JuvixError, Error ScoperError, Builtins, NameIdGen, Reader Pragmas, MCache, State ConstructorInfos] r =>
|
||||
(Members '[Reader EntryPoint, Reader ExportsTable, Error JuvixError, Error ScoperError, Builtins, NameIdGen, Reader Pragmas, MCache, State ConstructorInfos] r) =>
|
||||
ModuleIndex ->
|
||||
Sem r Internal.Module
|
||||
goModuleNoCache (ModuleIndex m) = do
|
||||
@ -177,7 +177,7 @@ goModuleNoCache (ModuleIndex m) = do
|
||||
)
|
||||
return r
|
||||
|
||||
goPragmas :: Member (Reader Pragmas) r => Maybe ParsedPragmas -> Sem r Pragmas
|
||||
goPragmas :: (Member (Reader Pragmas) r) => Maybe ParsedPragmas -> Sem r Pragmas
|
||||
goPragmas p = do
|
||||
p' <- ask
|
||||
return $ p' <> p ^. _Just . withLocParam . withSourceValue
|
||||
@ -241,14 +241,14 @@ goTopModulePath p = goSymbolPretty (prettyText p) (S.topModulePathSymbol p)
|
||||
|
||||
fromPreModule ::
|
||||
forall r.
|
||||
Members '[Reader Internal.NameDependencyInfo, Error ScoperError, Builtins, NameIdGen, Reader Pragmas] r =>
|
||||
(Members '[Reader Internal.NameDependencyInfo, Error ScoperError, Builtins, NameIdGen, Reader Pragmas] r) =>
|
||||
Internal.PreModule ->
|
||||
Sem r Internal.Module
|
||||
fromPreModule = traverseOf Internal.moduleBody fromPreModuleBody
|
||||
|
||||
fromPreModuleBody ::
|
||||
forall r.
|
||||
Members '[Reader Internal.NameDependencyInfo, Error ScoperError, Builtins, NameIdGen, Reader Pragmas] r =>
|
||||
(Members '[Reader Internal.NameDependencyInfo, Error ScoperError, Builtins, NameIdGen, Reader Pragmas] r) =>
|
||||
Internal.PreModuleBody ->
|
||||
Sem r Internal.ModuleBody
|
||||
fromPreModuleBody b = do
|
||||
@ -281,7 +281,7 @@ fromPreModuleBody b = do
|
||||
|
||||
goModuleBody ::
|
||||
forall r.
|
||||
Members '[Reader ExportsTable, Error ScoperError, Builtins, NameIdGen, Reader Pragmas, MCache, State ConstructorInfos] r =>
|
||||
(Members '[Reader ExportsTable, Error ScoperError, Builtins, NameIdGen, Reader Pragmas, MCache, State ConstructorInfos] r) =>
|
||||
[Statement 'Scoped] ->
|
||||
Sem r Internal.PreModuleBody
|
||||
goModuleBody stmts = do
|
||||
@ -344,7 +344,7 @@ scanImports stmts = mconcatMap go stmts
|
||||
|
||||
goImport ::
|
||||
forall r.
|
||||
Members '[Reader ExportsTable, Error ScoperError, Builtins, NameIdGen, Reader Pragmas, MCache] r =>
|
||||
(Members '[Reader ExportsTable, Error ScoperError, Builtins, NameIdGen, Reader Pragmas, MCache] r) =>
|
||||
Import 'Scoped ->
|
||||
Sem r Internal.Import
|
||||
goImport Import {..} = do
|
||||
@ -364,7 +364,7 @@ guardNotCached (hit, m) = do
|
||||
-- | Ignores functions
|
||||
goAxiomInductive ::
|
||||
forall r.
|
||||
Members '[Error ScoperError, Builtins, NameIdGen, Reader Pragmas, State ConstructorInfos] r =>
|
||||
(Members '[Error ScoperError, Builtins, NameIdGen, Reader Pragmas, State ConstructorInfos] r) =>
|
||||
Statement 'Scoped ->
|
||||
Sem r [Internal.PreStatement]
|
||||
goAxiomInductive = \case
|
||||
@ -379,7 +379,7 @@ goAxiomInductive = \case
|
||||
|
||||
goOpenModule' ::
|
||||
forall r.
|
||||
Members '[Reader ExportsTable, Error ScoperError, Builtins, NameIdGen, Reader Pragmas, MCache] r =>
|
||||
(Members '[Reader ExportsTable, Error ScoperError, Builtins, NameIdGen, Reader Pragmas, MCache] r) =>
|
||||
OpenModule 'Scoped ->
|
||||
Sem r (Maybe Internal.Import)
|
||||
goOpenModule' o =
|
||||
@ -399,14 +399,14 @@ goOpenModule' o =
|
||||
|
||||
goOpenModule ::
|
||||
forall r.
|
||||
Members '[Reader ExportsTable, Error ScoperError, Builtins, NameIdGen, Reader Pragmas, MCache] r =>
|
||||
(Members '[Reader ExportsTable, Error ScoperError, Builtins, NameIdGen, Reader Pragmas, MCache] r) =>
|
||||
OpenModule 'Scoped ->
|
||||
Sem r (Maybe Internal.Import)
|
||||
goOpenModule o = goOpenModule' o
|
||||
|
||||
goProjectionDef ::
|
||||
forall r.
|
||||
Members '[NameIdGen, State ConstructorInfos] r =>
|
||||
(Members '[NameIdGen, State ConstructorInfos] r) =>
|
||||
ProjectionDef 'Scoped ->
|
||||
Sem r Internal.FunctionDef
|
||||
goProjectionDef ProjectionDef {..} = do
|
||||
@ -416,7 +416,7 @@ goProjectionDef ProjectionDef {..} = do
|
||||
|
||||
goTopFunctionDef ::
|
||||
forall r.
|
||||
Members '[Reader Pragmas, Error ScoperError, Builtins, NameIdGen] r =>
|
||||
(Members '[Reader Pragmas, Error ScoperError, Builtins, NameIdGen] r) =>
|
||||
FunctionDef 'Scoped ->
|
||||
Sem r Internal.FunctionDef
|
||||
goTopFunctionDef FunctionDef {..} = do
|
||||
@ -487,7 +487,7 @@ goTopFunctionDef FunctionDef {..} = do
|
||||
|
||||
goExamples ::
|
||||
forall r.
|
||||
Members '[Builtins, NameIdGen, Error ScoperError, Reader Pragmas] r =>
|
||||
(Members '[Builtins, NameIdGen, Error ScoperError, Reader Pragmas] r) =>
|
||||
Maybe (Judoc 'Scoped) ->
|
||||
Sem r [Internal.Example]
|
||||
goExamples = mapM goExample . maybe [] judocExamples
|
||||
@ -503,7 +503,7 @@ goExamples = mapM goExample . maybe [] judocExamples
|
||||
|
||||
goInductiveParameters ::
|
||||
forall r.
|
||||
Members '[Builtins, NameIdGen, Error ScoperError, Reader Pragmas] r =>
|
||||
(Members '[Builtins, NameIdGen, Error ScoperError, Reader Pragmas] r) =>
|
||||
InductiveParameters 'Scoped ->
|
||||
Sem r [Internal.InductiveParameter]
|
||||
goInductiveParameters params@InductiveParameters {..} = do
|
||||
@ -590,7 +590,7 @@ registerBuiltinAxiom d = \case
|
||||
BuiltinIntPrint -> registerIntPrint d
|
||||
|
||||
goInductive ::
|
||||
Members '[NameIdGen, Reader Pragmas, Builtins, Error ScoperError, State ConstructorInfos] r =>
|
||||
(Members '[NameIdGen, Reader Pragmas, Builtins, Error ScoperError, State ConstructorInfos] r) =>
|
||||
InductiveDef 'Scoped ->
|
||||
Sem r Internal.InductiveDef
|
||||
goInductive ty@InductiveDef {..} = do
|
||||
@ -620,14 +620,14 @@ goInductive ty@InductiveDef {..} = do
|
||||
return indDef
|
||||
|
||||
-- | Registers constructors so we can access them for generating field projections
|
||||
registerInductiveConstructors :: Members '[State ConstructorInfos] r => Internal.InductiveDef -> Sem r ()
|
||||
registerInductiveConstructors :: (Members '[State ConstructorInfos] r) => Internal.InductiveDef -> Sem r ()
|
||||
registerInductiveConstructors indDef = do
|
||||
m <- get
|
||||
put (foldr (uncurry HashMap.insert) m (mkConstructorEntries indDef))
|
||||
|
||||
goConstructorDef ::
|
||||
forall r.
|
||||
Members '[Builtins, NameIdGen, Error ScoperError, Reader Pragmas] r =>
|
||||
(Members '[Builtins, NameIdGen, Error ScoperError, Reader Pragmas] r) =>
|
||||
Internal.Expression ->
|
||||
ConstructorDef 'Scoped ->
|
||||
Sem r Internal.ConstructorDef
|
||||
@ -690,7 +690,7 @@ goLiteral = fmap go
|
||||
LitString s -> Internal.LitString s
|
||||
LitInteger i -> Internal.LitInteger i
|
||||
|
||||
goListPattern :: Members '[Builtins, Error ScoperError, NameIdGen] r => Concrete.ListPattern 'Scoped -> Sem r Internal.Pattern
|
||||
goListPattern :: (Members '[Builtins, Error ScoperError, NameIdGen] r) => Concrete.ListPattern 'Scoped -> Sem r Internal.Pattern
|
||||
goListPattern l = do
|
||||
nil_ <- getBuiltinName loc BuiltinListNil
|
||||
cons_ <- getBuiltinName loc BuiltinListCons
|
||||
@ -726,7 +726,7 @@ goListPattern l = do
|
||||
|
||||
goExpression ::
|
||||
forall r.
|
||||
Members '[Builtins, NameIdGen, Error ScoperError, Reader Pragmas] r =>
|
||||
(Members '[Builtins, NameIdGen, Error ScoperError, Reader Pragmas] r) =>
|
||||
Expression ->
|
||||
Sem r Internal.Expression
|
||||
goExpression = \case
|
||||
@ -922,7 +922,7 @@ goExpression = \case
|
||||
mkApp :: Internal.Expression -> Internal.Expression -> Internal.Expression
|
||||
mkApp a1 a2 = Internal.ExpressionApplication $ Internal.Application a1 a2 Explicit
|
||||
|
||||
goCase :: forall r. Members '[Builtins, NameIdGen, Error ScoperError, Reader Pragmas] r => Case 'Scoped -> Sem r Internal.Case
|
||||
goCase :: forall r. (Members '[Builtins, NameIdGen, Error ScoperError, Reader Pragmas] r) => Case 'Scoped -> Sem r Internal.Case
|
||||
goCase c = do
|
||||
_caseExpression <- goExpression (c ^. caseExpression)
|
||||
_caseBranches <- mapM goBranch (c ^. caseBranches)
|
||||
@ -937,7 +937,7 @@ goCase c = do
|
||||
_caseBranchExpression <- goExpression (b ^. caseBranchExpression)
|
||||
return Internal.CaseBranch {..}
|
||||
|
||||
goLambda :: forall r. Members '[Builtins, NameIdGen, Error ScoperError, Reader Pragmas] r => Lambda 'Scoped -> Sem r Internal.Lambda
|
||||
goLambda :: forall r. (Members '[Builtins, NameIdGen, Error ScoperError, Reader Pragmas] r) => Lambda 'Scoped -> Sem r Internal.Lambda
|
||||
goLambda l = do
|
||||
clauses' <- mapM goClause (l ^. lambdaClauses)
|
||||
return
|
||||
@ -957,7 +957,7 @@ goUniverse u
|
||||
| isSmallUniverse u = SmallUniverse (getLoc u)
|
||||
| otherwise = error "only small universe is supported"
|
||||
|
||||
goFunction :: Members '[Builtins, NameIdGen, Error ScoperError, Reader Pragmas] r => Function 'Scoped -> Sem r Internal.Function
|
||||
goFunction :: (Members '[Builtins, NameIdGen, Error ScoperError, Reader Pragmas] r) => Function 'Scoped -> Sem r Internal.Function
|
||||
goFunction f = do
|
||||
params <- goFunctionParameters (f ^. funParameters)
|
||||
ret <- goExpression (f ^. funReturn)
|
||||
@ -966,7 +966,7 @@ goFunction f = do
|
||||
foldr (\param acc -> Internal.ExpressionFunction $ Internal.Function param acc) ret (NonEmpty.tail params)
|
||||
|
||||
goFunctionParameters ::
|
||||
Members '[Builtins, NameIdGen, Error ScoperError, Reader Pragmas] r =>
|
||||
(Members '[Builtins, NameIdGen, Error ScoperError, Reader Pragmas] r) =>
|
||||
FunctionParameters 'Scoped ->
|
||||
Sem r (NonEmpty Internal.FunctionParameter)
|
||||
goFunctionParameters FunctionParameters {..} = do
|
||||
@ -989,30 +989,30 @@ mkConstructorApp :: Internal.ConstrName -> [Internal.PatternArg] -> Internal.Con
|
||||
mkConstructorApp a b = Internal.ConstructorApp a b Nothing
|
||||
|
||||
goPatternApplication ::
|
||||
Members '[Builtins, NameIdGen, Error ScoperError] r =>
|
||||
(Members '[Builtins, NameIdGen, Error ScoperError] r) =>
|
||||
PatternApp ->
|
||||
Sem r Internal.ConstructorApp
|
||||
goPatternApplication a = uncurry mkConstructorApp <$> viewApp (PatternApplication a)
|
||||
|
||||
goPatternConstructor ::
|
||||
Members '[Builtins, NameIdGen, Error ScoperError] r =>
|
||||
(Members '[Builtins, NameIdGen, Error ScoperError] r) =>
|
||||
ScopedIden ->
|
||||
Sem r Internal.ConstructorApp
|
||||
goPatternConstructor a = uncurry mkConstructorApp <$> viewApp (PatternConstructor a)
|
||||
|
||||
goInfixPatternApplication ::
|
||||
Members '[Builtins, NameIdGen, Error ScoperError] r =>
|
||||
(Members '[Builtins, NameIdGen, Error ScoperError] r) =>
|
||||
PatternInfixApp ->
|
||||
Sem r Internal.ConstructorApp
|
||||
goInfixPatternApplication a = uncurry mkConstructorApp <$> viewApp (PatternInfixApplication a)
|
||||
|
||||
goPostfixPatternApplication ::
|
||||
Members '[Builtins, NameIdGen, Error ScoperError] r =>
|
||||
(Members '[Builtins, NameIdGen, Error ScoperError] r) =>
|
||||
PatternPostfixApp ->
|
||||
Sem r Internal.ConstructorApp
|
||||
goPostfixPatternApplication a = uncurry mkConstructorApp <$> viewApp (PatternPostfixApplication a)
|
||||
|
||||
viewApp :: forall r. Members '[Builtins, NameIdGen, Error ScoperError] r => Pattern -> Sem r (Internal.ConstrName, [Internal.PatternArg])
|
||||
viewApp :: forall r. (Members '[Builtins, NameIdGen, Error ScoperError] r) => Pattern -> Sem r (Internal.ConstrName, [Internal.PatternArg])
|
||||
viewApp p = case p of
|
||||
PatternConstructor c -> return (goScopedIden c, [])
|
||||
PatternApplication app@(PatternApp _ r) -> do
|
||||
@ -1037,7 +1037,7 @@ viewApp p = case p of
|
||||
| otherwise = viewApp (l ^. patternArgPattern)
|
||||
err = throw (ErrConstructorExpectedLeftApplication (ConstructorExpectedLeftApplication p))
|
||||
|
||||
goPatternArg :: Members '[Builtins, NameIdGen, Error ScoperError] r => PatternArg -> Sem r Internal.PatternArg
|
||||
goPatternArg :: (Members '[Builtins, NameIdGen, Error ScoperError] r) => PatternArg -> Sem r Internal.PatternArg
|
||||
goPatternArg p = do
|
||||
pat' <- goPattern (p ^. patternArgPattern)
|
||||
return
|
||||
@ -1047,7 +1047,7 @@ goPatternArg p = do
|
||||
_patternArgPattern = pat'
|
||||
}
|
||||
|
||||
goPattern :: Members '[Builtins, NameIdGen, Error ScoperError] r => Pattern -> Sem r Internal.Pattern
|
||||
goPattern :: (Members '[Builtins, NameIdGen, Error ScoperError] r) => Pattern -> Sem r Internal.Pattern
|
||||
goPattern p = case p of
|
||||
PatternVariable a -> return $ Internal.PatternVariable (goSymbol a)
|
||||
PatternList a -> goListPattern a
|
||||
@ -1059,7 +1059,7 @@ goPattern p = case p of
|
||||
PatternRecord i -> goRecordPattern i
|
||||
PatternEmpty {} -> error "unsupported empty pattern"
|
||||
|
||||
goRecordPattern :: forall r. Members '[NameIdGen, Error ScoperError, Builtins] r => RecordPattern 'Scoped -> Sem r Internal.Pattern
|
||||
goRecordPattern :: forall r. (Members '[NameIdGen, Error ScoperError, Builtins] r) => RecordPattern 'Scoped -> Sem r Internal.Pattern
|
||||
goRecordPattern r = do
|
||||
let constr = goScopedIden (r ^. recordPatternConstructor)
|
||||
params' <- mkPatterns
|
||||
|
@ -19,7 +19,7 @@ makeLenses ''BuilderState
|
||||
|
||||
runNamedArguments ::
|
||||
forall r.
|
||||
Members '[NameIdGen, Error ScoperError] r =>
|
||||
(Members '[NameIdGen, Error ScoperError] r) =>
|
||||
NamedApplication 'Scoped ->
|
||||
Sem r Expression
|
||||
runNamedArguments napp = do
|
||||
@ -42,7 +42,7 @@ runNamedArguments napp = do
|
||||
|
||||
helper ::
|
||||
forall r.
|
||||
Members '[State BuilderState, Output Expression, NameIdGen, Error NamedArgumentsError] r =>
|
||||
(Members '[State BuilderState, Output Expression, NameIdGen, Error NamedArgumentsError] r) =>
|
||||
Interval ->
|
||||
Sem r ()
|
||||
helper loc = do
|
||||
@ -132,7 +132,7 @@ helper loc = do
|
||||
go (n' + 1) rest
|
||||
where
|
||||
fillUntil n' = replicateM_ (n' - n) (mkWildcard >>= output)
|
||||
mkWildcard :: Members '[NameIdGen] r' => Sem r' Expression
|
||||
mkWildcard :: (Members '[NameIdGen] r') => Sem r' Expression
|
||||
mkWildcard = ExpressionBraces . WithLoc loc . ExpressionHole . mkHole loc <$> freshNameId
|
||||
maxIx :: Maybe Int
|
||||
maxIx = fmap maximum1 . nonEmpty . toList $ omittedArgs
|
||||
@ -145,7 +145,7 @@ helper loc = do
|
||||
scanGroup impl names = runOutputList . runState names . execState mempty . mapM_ go
|
||||
where
|
||||
go ::
|
||||
Members '[State (IntMap Expression), State (HashMap Symbol Int), State BuilderState, Output (NamedArgument 'Scoped), Error NamedArgumentsError] r' =>
|
||||
(Members '[State (IntMap Expression), State (HashMap Symbol Int), State BuilderState, Output (NamedArgument 'Scoped), Error NamedArgumentsError] r') =>
|
||||
NamedArgument 'Scoped ->
|
||||
Sem r' ()
|
||||
go arg = do
|
||||
|
@ -54,7 +54,7 @@ arityCheckExpression exp = do
|
||||
$ ArityChecking.inferReplExpression exp
|
||||
|
||||
arityCheckImport ::
|
||||
Members '[Error JuvixError, State Artifacts] r =>
|
||||
(Members '[Error JuvixError, State Artifacts] r) =>
|
||||
Import ->
|
||||
Sem r Import
|
||||
arityCheckImport i = do
|
||||
@ -92,7 +92,7 @@ typeCheckExpression ::
|
||||
typeCheckExpression exp = (^. typedExpression) <$> typeCheckExpressionType exp
|
||||
|
||||
typeCheckImport ::
|
||||
Members '[Reader EntryPoint, Error JuvixError, State Artifacts] r =>
|
||||
(Members '[Reader EntryPoint, Error JuvixError, State Artifacts] r) =>
|
||||
Import ->
|
||||
Sem r Import
|
||||
typeCheckImport i = do
|
||||
@ -113,7 +113,7 @@ typeCheckImport i = do
|
||||
$ checkImport i
|
||||
|
||||
typeChecking ::
|
||||
Members '[HighlightBuilder, Error JuvixError, Builtins, NameIdGen] r =>
|
||||
(Members '[HighlightBuilder, Error JuvixError, Builtins, NameIdGen] r) =>
|
||||
ArityChecking.InternalArityResult ->
|
||||
Sem r InternalTypedResult
|
||||
typeChecking res@ArityChecking.InternalArityResult {..} =
|
||||
|
@ -16,13 +16,13 @@ import Juvix.Prelude hiding (fromEither)
|
||||
type MCache = Cache ModuleIndex Module
|
||||
|
||||
checkModule ::
|
||||
Members '[Reader InfoTable, NameIdGen, Error ArityCheckerError, MCache] r =>
|
||||
(Members '[Reader InfoTable, NameIdGen, Error ArityCheckerError, MCache] r) =>
|
||||
Module ->
|
||||
Sem r Module
|
||||
checkModule = cacheGet . ModuleIndex
|
||||
|
||||
checkModuleIndexNoCache ::
|
||||
Members '[Reader InfoTable, NameIdGen, Error ArityCheckerError, MCache] r =>
|
||||
(Members '[Reader InfoTable, NameIdGen, Error ArityCheckerError, MCache] r) =>
|
||||
ModuleIndex ->
|
||||
Sem r Module
|
||||
checkModuleIndexNoCache (ModuleIndex Module {..}) = do
|
||||
@ -34,7 +34,7 @@ checkModuleIndexNoCache (ModuleIndex Module {..}) = do
|
||||
}
|
||||
|
||||
checkModuleBody ::
|
||||
Members '[Reader InfoTable, NameIdGen, Error ArityCheckerError, MCache] r =>
|
||||
(Members '[Reader InfoTable, NameIdGen, Error ArityCheckerError, MCache] r) =>
|
||||
ModuleBody ->
|
||||
Sem r ModuleBody
|
||||
checkModuleBody ModuleBody {..} = do
|
||||
@ -47,13 +47,13 @@ checkModuleBody ModuleBody {..} = do
|
||||
}
|
||||
|
||||
checkModuleIndex ::
|
||||
Members '[Reader InfoTable, NameIdGen, Error ArityCheckerError, MCache] r =>
|
||||
(Members '[Reader InfoTable, NameIdGen, Error ArityCheckerError, MCache] r) =>
|
||||
ModuleIndex ->
|
||||
Sem r ModuleIndex
|
||||
checkModuleIndex (ModuleIndex m) = ModuleIndex <$> checkModule m
|
||||
|
||||
checkImport ::
|
||||
Members '[Reader InfoTable, NameIdGen, Error ArityCheckerError, MCache] r =>
|
||||
(Members '[Reader InfoTable, NameIdGen, Error ArityCheckerError, MCache] r) =>
|
||||
Import ->
|
||||
Sem r Import
|
||||
checkImport = traverseOf importModule checkModuleIndex
|
||||
@ -166,7 +166,7 @@ checkFunctionClause ari cl = do
|
||||
simplelambda :: a
|
||||
simplelambda = error "simple lambda expressions are not supported by the arity checker"
|
||||
|
||||
withLocalVar :: Members '[Reader LocalVars] r => Arity -> VarName -> Sem r a -> Sem r a
|
||||
withLocalVar :: (Members '[Reader LocalVars] r) => Arity -> VarName -> Sem r a -> Sem r a
|
||||
withLocalVar ari v = local (withArity v ari)
|
||||
|
||||
withEmptyLocalVars :: Sem (Reader LocalVars ': r) a -> Sem r a
|
||||
@ -175,7 +175,7 @@ withEmptyLocalVars = runReader emptyLocalVars
|
||||
arityLet :: (Members '[Reader InfoTable] r) => Let -> Sem r Arity
|
||||
arityLet l = guessArity (l ^. letExpression)
|
||||
|
||||
inferReplExpression :: Members '[Reader InfoTable, NameIdGen, Error ArityCheckerError] r => Expression -> Sem r Expression
|
||||
inferReplExpression :: (Members '[Reader InfoTable, NameIdGen, Error ArityCheckerError] r) => Expression -> Sem r Expression
|
||||
inferReplExpression e = do
|
||||
ari <- guessArity e
|
||||
withEmptyLocalVars (checkExpression ari e)
|
||||
@ -233,7 +233,7 @@ arityUniverse = ArityUnit
|
||||
-- | All branches should have the same arity. If they are all the same, we
|
||||
-- return that, otherwise we return ArityUnknown. Probably something better can
|
||||
-- be done.
|
||||
arityCase :: Members '[Reader InfoTable] r => Case -> Sem r Arity
|
||||
arityCase :: (Members '[Reader InfoTable] r) => Case -> Sem r Arity
|
||||
arityCase c = do
|
||||
aris <- mapM (guessArity . (^. caseBranchExpression)) (c ^. caseBranches)
|
||||
return
|
||||
@ -387,7 +387,7 @@ checkConstructorApp ca = do
|
||||
|
||||
checkCase ::
|
||||
forall r.
|
||||
Members '[Error ArityCheckerError, Reader LocalVars, Reader InfoTable, NameIdGen] r =>
|
||||
(Members '[Error ArityCheckerError, Reader LocalVars, Reader InfoTable, NameIdGen] r) =>
|
||||
Arity ->
|
||||
Case ->
|
||||
Sem r Case
|
||||
|
@ -30,7 +30,7 @@ type CheckPositivityEffects r =
|
||||
|
||||
checkPositivity ::
|
||||
forall r.
|
||||
CheckPositivityEffects r =>
|
||||
(CheckPositivityEffects r) =>
|
||||
InductiveDef ->
|
||||
Sem r ()
|
||||
checkPositivity ty = do
|
||||
@ -47,7 +47,7 @@ checkPositivity ty = do
|
||||
|
||||
checkStrictlyPositiveOccurrences ::
|
||||
forall r.
|
||||
CheckPositivityEffects r =>
|
||||
(CheckPositivityEffects r) =>
|
||||
InductiveDef ->
|
||||
ConstrName ->
|
||||
Name ->
|
||||
|
@ -10,7 +10,7 @@ import Juvix.Prelude
|
||||
|
||||
type MCache = Cache ModuleIndex Module
|
||||
|
||||
filterUnreachable :: Members '[Reader EntryPoint] r => Typed.InternalTypedResult -> Sem r Typed.InternalTypedResult
|
||||
filterUnreachable :: (Members '[Reader EntryPoint] r) => Typed.InternalTypedResult -> Sem r Typed.InternalTypedResult
|
||||
filterUnreachable r = do
|
||||
asks (^. entryPointSymbolPruningMode) >>= \case
|
||||
KeepAll -> return r
|
||||
@ -24,17 +24,17 @@ filterUnreachable r = do
|
||||
. evalCacheEmpty goModuleNoCache
|
||||
$ mapM goModule modules
|
||||
|
||||
askIsReachable :: Member (Reader NameDependencyInfo) r => Name -> Sem r Bool
|
||||
askIsReachable :: (Member (Reader NameDependencyInfo) r) => Name -> Sem r Bool
|
||||
askIsReachable n = do
|
||||
depInfo <- ask
|
||||
return (isReachable depInfo n)
|
||||
|
||||
returnIfReachable :: Member (Reader NameDependencyInfo) r => Name -> a -> Sem r (Maybe a)
|
||||
returnIfReachable :: (Member (Reader NameDependencyInfo) r) => Name -> a -> Sem r (Maybe a)
|
||||
returnIfReachable n a = do
|
||||
r <- askIsReachable n
|
||||
return (guard r $> a)
|
||||
|
||||
goModuleNoCache :: forall r. Members '[Reader NameDependencyInfo, MCache] r => ModuleIndex -> Sem r Module
|
||||
goModuleNoCache :: forall r. (Members '[Reader NameDependencyInfo, MCache] r) => ModuleIndex -> Sem r Module
|
||||
goModuleNoCache (ModuleIndex m) = do
|
||||
body' <- goBody (m ^. moduleBody)
|
||||
return (set moduleBody body' m)
|
||||
@ -45,13 +45,13 @@ goModuleNoCache (ModuleIndex m) = do
|
||||
_moduleImports <- mapM goImport (body ^. moduleImports)
|
||||
return ModuleBody {..}
|
||||
|
||||
goModule :: Members '[Reader NameDependencyInfo, MCache] r => Module -> Sem r Module
|
||||
goModule :: (Members '[Reader NameDependencyInfo, MCache] r) => Module -> Sem r Module
|
||||
goModule = cacheGet . ModuleIndex
|
||||
|
||||
goModuleIndex :: Members '[Reader NameDependencyInfo, MCache] r => ModuleIndex -> Sem r ModuleIndex
|
||||
goModuleIndex :: (Members '[Reader NameDependencyInfo, MCache] r) => ModuleIndex -> Sem r ModuleIndex
|
||||
goModuleIndex = fmap ModuleIndex . cacheGet
|
||||
|
||||
goStatement :: forall r. Member (Reader NameDependencyInfo) r => Statement -> Sem r (Maybe Statement)
|
||||
goStatement :: forall r. (Member (Reader NameDependencyInfo) r) => Statement -> Sem r (Maybe Statement)
|
||||
goStatement s = case s of
|
||||
StatementMutual m -> fmap StatementMutual <$> goMutual m
|
||||
StatementAxiom ax -> returnIfReachable (ax ^. axiomName) s
|
||||
@ -62,7 +62,7 @@ goStatement s = case s of
|
||||
StatementFunction f -> returnIfReachable (f ^. funDefName) b
|
||||
StatementInductive f -> returnIfReachable (f ^. inductiveName) b
|
||||
|
||||
goImport :: forall r. Members '[Reader NameDependencyInfo, MCache] r => Import -> Sem r Import
|
||||
goImport :: forall r. (Members '[Reader NameDependencyInfo, MCache] r) => Import -> Sem r Import
|
||||
goImport i = do
|
||||
_importModule <- goModuleIndex (i ^. importModule)
|
||||
return Import {..}
|
||||
|
@ -15,7 +15,7 @@ import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.Termination.Lex
|
||||
import Juvix.Prelude
|
||||
|
||||
checkTermination ::
|
||||
Members '[Error TerminationError] r =>
|
||||
(Members '[Error TerminationError] r) =>
|
||||
InfoTable ->
|
||||
Module ->
|
||||
Sem r ()
|
||||
@ -42,7 +42,7 @@ buildCallMap :: InfoTable -> Module -> CallMap
|
||||
buildCallMap infotable = run . execState mempty . runReader infotable . scanModule
|
||||
|
||||
scanModule ::
|
||||
Members '[State CallMap] r =>
|
||||
(Members '[State CallMap] r) =>
|
||||
Module ->
|
||||
Sem r ()
|
||||
scanModule m = scanModuleBody (m ^. moduleBody)
|
||||
@ -108,12 +108,12 @@ scanLet l = do
|
||||
scanExpression (l ^. letExpression)
|
||||
|
||||
-- NOTE that we forget about the arguments of the hosting function
|
||||
scanLetClause :: Members '[State CallMap] r => LetClause -> Sem r ()
|
||||
scanLetClause :: (Members '[State CallMap] r) => LetClause -> Sem r ()
|
||||
scanLetClause = \case
|
||||
LetFunDef d -> scanFunctionDef d
|
||||
LetMutualBlock m -> scanMutualBlockLet m
|
||||
|
||||
scanMutualBlockLet :: Members '[State CallMap] r => MutualBlockLet -> Sem r ()
|
||||
scanMutualBlockLet :: (Members '[State CallMap] r) => MutualBlockLet -> Sem r ()
|
||||
scanMutualBlockLet MutualBlockLet {..} = mapM_ scanFunctionDef _mutualLet
|
||||
|
||||
scanExpression ::
|
||||
|
@ -20,30 +20,30 @@ import Juvix.Prelude hiding (fromEither)
|
||||
|
||||
type MCache = Cache ModuleIndex Module
|
||||
|
||||
registerConstructor :: Members '[HighlightBuilder, State TypesTable, Reader InfoTable] r => ConstructorDef -> Sem r ()
|
||||
registerConstructor :: (Members '[HighlightBuilder, State TypesTable, Reader InfoTable] r) => ConstructorDef -> Sem r ()
|
||||
registerConstructor ctr = do
|
||||
ty <- lookupConstructorType (ctr ^. inductiveConstructorName)
|
||||
registerNameIdType (ctr ^. inductiveConstructorName . nameId) ty
|
||||
|
||||
registerNameIdType :: Members '[HighlightBuilder, State TypesTable, Reader InfoTable] r => NameId -> Expression -> Sem r ()
|
||||
registerNameIdType :: (Members '[HighlightBuilder, State TypesTable, Reader InfoTable] r) => NameId -> Expression -> Sem r ()
|
||||
registerNameIdType uid ty = do
|
||||
modify (HashMap.insert uid ty)
|
||||
modify (set (highlightTypes . at uid) (Just ty))
|
||||
|
||||
checkModule ::
|
||||
Members '[HighlightBuilder, Reader EntryPoint, Reader InfoTable, Error TypeCheckerError, NameIdGen, State TypesTable, State FunctionsTable, Output Example, Builtins, MCache] r =>
|
||||
(Members '[HighlightBuilder, Reader EntryPoint, Reader InfoTable, Error TypeCheckerError, NameIdGen, State TypesTable, State FunctionsTable, Output Example, Builtins, MCache] r) =>
|
||||
Module ->
|
||||
Sem r Module
|
||||
checkModule = cacheGet . ModuleIndex
|
||||
|
||||
checkModuleIndex ::
|
||||
Members '[HighlightBuilder, Reader EntryPoint, Reader InfoTable, Error TypeCheckerError, NameIdGen, State TypesTable, State FunctionsTable, Output Example, Builtins, MCache] r =>
|
||||
(Members '[HighlightBuilder, Reader EntryPoint, Reader InfoTable, Error TypeCheckerError, NameIdGen, State TypesTable, State FunctionsTable, Output Example, Builtins, MCache] r) =>
|
||||
ModuleIndex ->
|
||||
Sem r ModuleIndex
|
||||
checkModuleIndex = fmap ModuleIndex . cacheGet
|
||||
|
||||
checkModuleNoCache ::
|
||||
Members '[HighlightBuilder, Reader EntryPoint, Reader InfoTable, Error TypeCheckerError, NameIdGen, State TypesTable, State FunctionsTable, Output Example, Builtins, MCache] r =>
|
||||
(Members '[HighlightBuilder, Reader EntryPoint, Reader InfoTable, Error TypeCheckerError, NameIdGen, State TypesTable, State FunctionsTable, Output Example, Builtins, MCache] r) =>
|
||||
ModuleIndex ->
|
||||
Sem r Module
|
||||
checkModuleNoCache (ModuleIndex Module {..}) = do
|
||||
@ -61,7 +61,7 @@ checkModuleNoCache (ModuleIndex Module {..}) = do
|
||||
}
|
||||
|
||||
checkModuleBody ::
|
||||
Members '[HighlightBuilder, Reader EntryPoint, State NegativeTypeParameters, Reader InfoTable, Error TypeCheckerError, NameIdGen, State TypesTable, State FunctionsTable, Output Example, Builtins, MCache] r =>
|
||||
(Members '[HighlightBuilder, Reader EntryPoint, State NegativeTypeParameters, Reader InfoTable, Error TypeCheckerError, NameIdGen, State TypesTable, State FunctionsTable, Output Example, Builtins, MCache] r) =>
|
||||
ModuleBody ->
|
||||
Sem r ModuleBody
|
||||
checkModuleBody ModuleBody {..} = do
|
||||
@ -74,7 +74,7 @@ checkModuleBody ModuleBody {..} = do
|
||||
}
|
||||
|
||||
checkImport ::
|
||||
Members '[HighlightBuilder, Reader EntryPoint, Reader InfoTable, Error TypeCheckerError, NameIdGen, State TypesTable, State FunctionsTable, Output Example, Builtins, MCache] r =>
|
||||
(Members '[HighlightBuilder, Reader EntryPoint, Reader InfoTable, Error TypeCheckerError, NameIdGen, State TypesTable, State FunctionsTable, Output Example, Builtins, MCache] r) =>
|
||||
Import ->
|
||||
Sem r Import
|
||||
checkImport = traverseOf importModule checkModuleIndex
|
||||
|
@ -412,7 +412,7 @@ runInferenceDef ::
|
||||
Sem r funDef
|
||||
runInferenceDef = fmap head . runInferenceDefs . fmap pure
|
||||
|
||||
addIdens :: Members '[HighlightBuilder, State TypesTable] r => TypesTable -> Sem r ()
|
||||
addIdens :: (Members '[HighlightBuilder, State TypesTable] r) => TypesTable -> Sem r ()
|
||||
addIdens idens = do
|
||||
modify (HashMap.union idens)
|
||||
modify (over highlightTypes (HashMap.union idens))
|
||||
@ -420,14 +420,14 @@ addIdens idens = do
|
||||
-- | Assumes the given function has been type checked.
|
||||
-- Does *not* register the function.
|
||||
-- Throws an error if the return type is Type and returns Nothing.
|
||||
functionDefEval :: forall r'. Members '[State FunctionsTable, Error TypeCheckerError] r' => FunctionDef -> Sem r' (Maybe Expression)
|
||||
functionDefEval :: forall r'. (Members '[State FunctionsTable, Error TypeCheckerError] r') => FunctionDef -> Sem r' (Maybe Expression)
|
||||
functionDefEval f = do
|
||||
r <- runFail goTop
|
||||
retTy <- returnsType
|
||||
when (isNothing r && retTy) (throw (ErrUnsupportedTypeFunction (UnsupportedTypeFunction f)))
|
||||
return r
|
||||
where
|
||||
isUniverse :: Members '[State FunctionsTable] r => Expression -> Sem r Bool
|
||||
isUniverse :: (Members '[State FunctionsTable] r) => Expression -> Sem r Bool
|
||||
isUniverse e = do
|
||||
e' <- evalState iniState (weakNormalize' e)
|
||||
case e' of
|
||||
@ -436,10 +436,10 @@ functionDefEval f = do
|
||||
|
||||
(params, ret) = unfoldFunType (f ^. funDefType)
|
||||
|
||||
returnsType :: Members '[State FunctionsTable] r => Sem r Bool
|
||||
returnsType :: (Members '[State FunctionsTable] r) => Sem r Bool
|
||||
returnsType = isUniverse ret
|
||||
|
||||
goTop :: forall r. Members '[Fail, State FunctionsTable, Error TypeCheckerError] r => Sem r Expression
|
||||
goTop :: forall r. (Members '[Fail, State FunctionsTable, Error TypeCheckerError] r) => Sem r Expression
|
||||
goTop =
|
||||
case f ^. funDefClauses of
|
||||
c :| [] -> goClause c
|
||||
@ -472,6 +472,6 @@ functionDefEval f = do
|
||||
| Implicit <- p ^. patternArgIsImplicit -> fail
|
||||
| otherwise -> go ps >>= goPattern (p ^. patternArgPattern, ty)
|
||||
|
||||
registerFunctionDef :: Members '[State FunctionsTable, Error TypeCheckerError] r => FunctionDef -> Sem r ()
|
||||
registerFunctionDef :: (Members '[State FunctionsTable, Error TypeCheckerError] r) => FunctionDef -> Sem r ()
|
||||
registerFunctionDef f = whenJustM (functionDefEval f) $ \e ->
|
||||
modify (over functionsTable (HashMap.insert (f ^. funDefName) e))
|
||||
|
@ -78,7 +78,7 @@ upToInternalReachability =
|
||||
upToInternalTyped >>= Internal.filterUnreachable
|
||||
|
||||
upToCore ::
|
||||
Members '[HighlightBuilder, Reader EntryPoint, Files, NameIdGen, Error JuvixError, Builtins, PathResolver] r =>
|
||||
(Members '[HighlightBuilder, Reader EntryPoint, Files, NameIdGen, Error JuvixError, Builtins, PathResolver] r) =>
|
||||
Sem r Core.CoreResult
|
||||
upToCore = upToInternalReachability >>= Core.fromInternal
|
||||
|
||||
@ -122,35 +122,35 @@ upToEval =
|
||||
-- Internal workflows
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
coreToAsm :: Members '[Error JuvixError, Reader EntryPoint] r => Core.InfoTable -> Sem r Asm.InfoTable
|
||||
coreToAsm :: (Members '[Error JuvixError, Reader EntryPoint] r) => Core.InfoTable -> Sem r Asm.InfoTable
|
||||
coreToAsm = Core.toStripped >=> return . Asm.fromCore . Stripped.fromCore
|
||||
|
||||
coreToMiniC :: Members '[Error JuvixError, Reader EntryPoint] r => Core.InfoTable -> Sem r C.MiniCResult
|
||||
coreToMiniC :: (Members '[Error JuvixError, Reader EntryPoint] r) => Core.InfoTable -> Sem r C.MiniCResult
|
||||
coreToMiniC = coreToAsm >=> asmToMiniC
|
||||
|
||||
asmToMiniC :: Members '[Error JuvixError, Reader EntryPoint] r => Asm.InfoTable -> Sem r C.MiniCResult
|
||||
asmToMiniC :: (Members '[Error JuvixError, Reader EntryPoint] r) => Asm.InfoTable -> Sem r C.MiniCResult
|
||||
asmToMiniC = Asm.toReg >=> regToMiniC . Reg.fromAsm
|
||||
|
||||
regToMiniC :: Member (Reader EntryPoint) r => Reg.InfoTable -> Sem r C.MiniCResult
|
||||
regToMiniC :: (Member (Reader EntryPoint) r) => Reg.InfoTable -> Sem r C.MiniCResult
|
||||
regToMiniC tab = do
|
||||
e <- ask
|
||||
return $ C.fromReg (Backend.getLimits (e ^. entryPointTarget) (e ^. entryPointDebug)) tab
|
||||
|
||||
coreToGeb :: Members '[Error JuvixError, Reader EntryPoint] r => Geb.ResultSpec -> Core.InfoTable -> Sem r Geb.Result
|
||||
coreToGeb :: (Members '[Error JuvixError, Reader EntryPoint] r) => Geb.ResultSpec -> Core.InfoTable -> Sem r Geb.Result
|
||||
coreToGeb spec = Core.toGeb >=> return . uncurry (Geb.toResult spec) . Geb.fromCore
|
||||
|
||||
coreToVampIR :: Members '[Error JuvixError, Reader EntryPoint] r => Core.InfoTable -> Sem r VampIR.Result
|
||||
coreToVampIR :: (Members '[Error JuvixError, Reader EntryPoint] r) => Core.InfoTable -> Sem r VampIR.Result
|
||||
coreToVampIR = Core.toVampIR >=> return . VampIR.toResult . VampIR.fromCore
|
||||
|
||||
asmToMiniC' :: Members '[Error JuvixError, Reader Asm.Options] r => Asm.InfoTable -> Sem r C.MiniCResult
|
||||
asmToMiniC' :: (Members '[Error JuvixError, Reader Asm.Options] r) => Asm.InfoTable -> Sem r C.MiniCResult
|
||||
asmToMiniC' = mapError (JuvixError @Asm.AsmError) . Asm.toReg' >=> regToMiniC' . Reg.fromAsm
|
||||
|
||||
regToMiniC' :: Member (Reader Asm.Options) r => Reg.InfoTable -> Sem r C.MiniCResult
|
||||
regToMiniC' :: (Member (Reader Asm.Options) r) => Reg.InfoTable -> Sem r C.MiniCResult
|
||||
regToMiniC' tab = do
|
||||
e <- ask
|
||||
return $ C.fromReg (e ^. Asm.optLimits) tab
|
||||
|
||||
coreToVampIR' :: Members '[Error JuvixError, Reader Core.CoreOptions] r => Core.InfoTable -> Sem r VampIR.Result
|
||||
coreToVampIR' :: (Members '[Error JuvixError, Reader Core.CoreOptions] r) => Core.InfoTable -> Sem r VampIR.Result
|
||||
coreToVampIR' = Core.toVampIR' >=> return . VampIR.toResult . VampIR.fromCore
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
@ -52,29 +52,29 @@ makeLenses ''Artifacts
|
||||
extendedTableReplArtifacts :: forall r. (Members '[State Artifacts] r) => Internal.Expression -> Sem r Internal.InfoTable
|
||||
extendedTableReplArtifacts e = Internal.extendWithReplExpression e <$> gets (^. artifactInternalTypedTable)
|
||||
|
||||
runCoreInfoTableBuilderArtifacts :: Members '[State Artifacts] r => Sem (Core.InfoTableBuilder ': r) a -> Sem r a
|
||||
runCoreInfoTableBuilderArtifacts :: (Members '[State Artifacts] r) => Sem (Core.InfoTableBuilder ': r) a -> Sem r a
|
||||
runCoreInfoTableBuilderArtifacts = runStateLikeArtifacts Core.runInfoTableBuilder artifactCoreTable
|
||||
|
||||
tmpCoreInfoTableBuilderArtifacts :: Members '[State Artifacts] r => Sem (Core.InfoTableBuilder ': r) a -> Sem r a
|
||||
tmpCoreInfoTableBuilderArtifacts :: (Members '[State Artifacts] r) => Sem (Core.InfoTableBuilder ': r) a -> Sem r a
|
||||
tmpCoreInfoTableBuilderArtifacts m = do
|
||||
tbl <- gets (^. artifactCoreTable)
|
||||
a <- runStateLikeArtifacts Core.runInfoTableBuilder artifactCoreTable m
|
||||
modify' (set artifactCoreTable tbl)
|
||||
return a
|
||||
|
||||
runPathResolverArtifacts :: Members '[Files, Reader EntryPoint, State Artifacts] r => Sem (PathResolver ': r) a -> Sem r a
|
||||
runPathResolverArtifacts :: (Members '[Files, Reader EntryPoint, State Artifacts] r) => Sem (PathResolver ': r) a -> Sem r a
|
||||
runPathResolverArtifacts = runStateLikeArtifacts runPathResolverPipe' artifactResolver
|
||||
|
||||
runBuiltinsArtifacts :: Members '[Error JuvixError, State Artifacts] r => Sem (Builtins ': r) a -> Sem r a
|
||||
runBuiltinsArtifacts :: (Members '[Error JuvixError, State Artifacts] r) => Sem (Builtins ': r) a -> Sem r a
|
||||
runBuiltinsArtifacts = runStateLikeArtifacts runBuiltins artifactBuiltins
|
||||
|
||||
runParserInfoTableBuilderArtifacts :: Members '[State Artifacts] r => Sem (Concrete.InfoTableBuilder ': r) a -> Sem r a
|
||||
runParserInfoTableBuilderArtifacts :: (Members '[State Artifacts] r) => Sem (Concrete.InfoTableBuilder ': r) a -> Sem r a
|
||||
runParserInfoTableBuilderArtifacts = runStateLikeArtifacts Concrete.runParserInfoTableBuilderRepl artifactParsing
|
||||
|
||||
runScoperInfoTableBuilderArtifacts :: Members '[State Artifacts] r => Sem (Scoped.InfoTableBuilder ': r) a -> Sem r a
|
||||
runScoperInfoTableBuilderArtifacts :: (Members '[State Artifacts] r) => Sem (Scoped.InfoTableBuilder ': r) a -> Sem r a
|
||||
runScoperInfoTableBuilderArtifacts = runStateLikeArtifacts Scoped.runInfoTableBuilderRepl artifactScopeTable
|
||||
|
||||
runScoperScopeArtifacts :: Members '[State Artifacts] r => Sem (State S.Scope ': r) a -> Sem r a
|
||||
runScoperScopeArtifacts :: (Members '[State Artifacts] r) => Sem (State S.Scope ': r) a -> Sem r a
|
||||
runScoperScopeArtifacts m = do
|
||||
s <- fromJust <$> gets (^. artifactMainModuleScope)
|
||||
(s', a) <- runState s m
|
||||
@ -82,30 +82,30 @@ runScoperScopeArtifacts m = do
|
||||
return a
|
||||
|
||||
runNameIdGenArtifacts ::
|
||||
Members '[State Artifacts] r =>
|
||||
(Members '[State Artifacts] r) =>
|
||||
Sem (NameIdGen ': r) a ->
|
||||
Sem r a
|
||||
runNameIdGenArtifacts = runStateLikeArtifacts runNameIdGen artifactNameIdState
|
||||
|
||||
runFunctionsTableArtifacts :: Members '[State Artifacts] r => Sem (State FunctionsTable ': r) a -> Sem r a
|
||||
runFunctionsTableArtifacts :: (Members '[State Artifacts] r) => Sem (State FunctionsTable ': r) a -> Sem r a
|
||||
runFunctionsTableArtifacts = runStateArtifacts artifactFunctions
|
||||
|
||||
readerTypesTableArtifacts :: Members '[State Artifacts] r => Sem (Reader TypesTable ': r) a -> Sem r a
|
||||
readerTypesTableArtifacts :: (Members '[State Artifacts] r) => Sem (Reader TypesTable ': r) a -> Sem r a
|
||||
readerTypesTableArtifacts = runReaderArtifacts artifactTypes
|
||||
|
||||
runTypesTableArtifacts :: Members '[State Artifacts] r => Sem (State TypesTable ': r) a -> Sem r a
|
||||
runTypesTableArtifacts :: (Members '[State Artifacts] r) => Sem (State TypesTable ': r) a -> Sem r a
|
||||
runTypesTableArtifacts = runStateArtifacts artifactTypes
|
||||
|
||||
runStateArtifacts :: Members '[State Artifacts] r => Lens' Artifacts f -> Sem (State f ': r) a -> Sem r a
|
||||
runStateArtifacts :: (Members '[State Artifacts] r) => Lens' Artifacts f -> Sem (State f ': r) a -> Sem r a
|
||||
runStateArtifacts = runStateLikeArtifacts runState
|
||||
|
||||
runReaderArtifacts :: Members '[State Artifacts] r => Lens' Artifacts f -> Sem (Reader f ': r) a -> Sem r a
|
||||
runReaderArtifacts :: (Members '[State Artifacts] r) => Lens' Artifacts f -> Sem (Reader f ': r) a -> Sem r a
|
||||
runReaderArtifacts l m = do
|
||||
s <- gets (^. l)
|
||||
runReader s m
|
||||
|
||||
runStateLikeArtifacts ::
|
||||
Members '[State Artifacts] r =>
|
||||
(Members '[State Artifacts] r) =>
|
||||
(field -> Sem (stateEff ': r) a -> Sem r (field, a)) ->
|
||||
Lens' Artifacts field ->
|
||||
Sem (stateEff ': r) a ->
|
||||
@ -125,7 +125,7 @@ runCacheArtifacts ::
|
||||
runCacheArtifacts l f = runStateLikeArtifacts (runCache f) l
|
||||
|
||||
runFromConcreteCache ::
|
||||
Members '[Reader EntryPoint, State Artifacts, Builtins, NameIdGen, Reader ExportsTable, Error JuvixError] r =>
|
||||
(Members '[Reader EntryPoint, State Artifacts, Builtins, NameIdGen, Reader ExportsTable, Error JuvixError] r) =>
|
||||
Sem (Internal.MCache ': r) a ->
|
||||
Sem r a
|
||||
runFromConcreteCache =
|
||||
|
@ -198,13 +198,13 @@ readGlobalPackageIO = do
|
||||
Left err -> putStrLn err >> exitFailure
|
||||
Right r -> return r
|
||||
|
||||
readGlobalPackage :: Members '[Error Text, Files] r => Sem r Package
|
||||
readGlobalPackage :: (Members '[Error Text, Files] r) => Sem r Package
|
||||
readGlobalPackage = do
|
||||
yamlPath <- globalYaml
|
||||
unlessM (fileExists' yamlPath) writeGlobalPackage
|
||||
readPackage (parent yamlPath) DefaultBuildDir
|
||||
|
||||
writeGlobalPackage :: Members '[Files] r => Sem r ()
|
||||
writeGlobalPackage :: (Members '[Files] r) => Sem r ()
|
||||
writeGlobalPackage = do
|
||||
yamlPath <- globalYaml
|
||||
ensureDir' (parent yamlPath)
|
||||
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue
Block a user