mirror of
https://github.com/anoma/juvix.git
synced 2024-10-26 17:52:17 +03:00
Print comments when pretty printing concrete syntax (#1737)
This commit is contained in:
parent
dd4aab16b6
commit
88ab622353
8
Makefile
8
Makefile
@ -238,11 +238,15 @@ fast-test-skip-slow:
|
||||
|
||||
SMOKE := $(shell command -v smoke 2> /dev/null)
|
||||
|
||||
.PHONY : smoke
|
||||
smoke: install submodules
|
||||
.PHONY : smoke-only
|
||||
smoke-only:
|
||||
@$(if $(SMOKE),, $(error "Smoke not found, please install it from https://github.com/SamirTalwar/smoke"))
|
||||
@smoke $(shell find tests -name '*.smoke.yaml')
|
||||
|
||||
.PHONY : smoke
|
||||
smoke: install submodules
|
||||
@${MAKE} smoke-only
|
||||
|
||||
# -- Release
|
||||
|
||||
.PHONY : changelog-updates
|
||||
|
@ -2,14 +2,28 @@ module Commands.Dev.Scope where
|
||||
|
||||
import Commands.Base
|
||||
import Commands.Dev.Scope.Options
|
||||
import Juvix.Compiler.Concrete.Language
|
||||
import Juvix.Compiler.Concrete.Pretty qualified as Scoper
|
||||
import Juvix.Compiler.Concrete.Print qualified as Print
|
||||
import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping qualified as Scoper
|
||||
import Juvix.Data.Comment
|
||||
import Juvix.Prelude.Pretty
|
||||
|
||||
runCommand :: (Members '[Embed IO, App] r) => ScopeOptions -> Sem r ()
|
||||
runCommand opts = do
|
||||
globalOpts <- askGlobalOptions
|
||||
l <-
|
||||
(^. Scoper.resultModules)
|
||||
<$> runPipeline (opts ^. scopeInputFile) upToScoping
|
||||
forM_ l $ \s -> do
|
||||
renderStdOut (Scoper.ppOut (globalOpts, opts) s)
|
||||
res :: Scoper.ScoperResult <- runPipeline (opts ^. scopeInputFile) upToScoping
|
||||
let modules :: NonEmpty (Module 'Scoped 'ModuleTop) = res ^. Scoper.resultModules
|
||||
forM_ modules $ \s ->
|
||||
if
|
||||
| opts ^. scopeWithComments ->
|
||||
renderStdOut (Print.ppOut (globalOpts, opts) (res ^. Scoper.comments) s)
|
||||
| otherwise ->
|
||||
renderStdOut (Scoper.ppOut (globalOpts, opts) s)
|
||||
when (opts ^. scopeListComments) $ do
|
||||
let mainFile :: Path Abs File = getLoc (res ^. Scoper.mainModule) ^. intervalFile
|
||||
newline
|
||||
newline
|
||||
say "Comments:"
|
||||
forM_ (fileComments mainFile (res ^. Scoper.comments) ^. fileCommentsSorted) $ \c ->
|
||||
say (prettyText (c ^. commentInterval) <> " " <> prettyText c)
|
||||
|
@ -5,8 +5,9 @@ import GlobalOptions
|
||||
import Juvix.Compiler.Concrete.Pretty qualified as Scoper
|
||||
|
||||
data ScopeOptions = ScopeOptions
|
||||
{ _scopeInlineImports :: Bool,
|
||||
_scopeInputFile :: AppPath File
|
||||
{ _scopeInputFile :: AppPath File,
|
||||
_scopeWithComments :: Bool,
|
||||
_scopeListComments :: Bool
|
||||
}
|
||||
deriving stock (Data)
|
||||
|
||||
@ -14,18 +15,22 @@ makeLenses ''ScopeOptions
|
||||
|
||||
parseScope :: Parser ScopeOptions
|
||||
parseScope = do
|
||||
_scopeInlineImports <-
|
||||
_scopeWithComments <-
|
||||
switch
|
||||
( long "inline-imports"
|
||||
<> help "Show the code of imported modules next to the import statement"
|
||||
( long "with-comments"
|
||||
<> help "Include user comments when printing code"
|
||||
)
|
||||
_scopeListComments <-
|
||||
switch
|
||||
( long "list-comments"
|
||||
<> help "List the user comments"
|
||||
)
|
||||
_scopeInputFile <- parseInputJuvixFile
|
||||
pure ScopeOptions {..}
|
||||
|
||||
instance CanonicalProjection (GlobalOptions, ScopeOptions) Scoper.Options where
|
||||
project (g, ScopeOptions {..}) =
|
||||
project (g, _) =
|
||||
Scoper.defaultOptions
|
||||
{ Scoper._optShowNameIds = g ^. globalShowNameIds,
|
||||
Scoper._optInlineImports = _scopeInlineImports,
|
||||
Scoper._optNoApe = g ^. globalNoApe
|
||||
}
|
||||
|
@ -317,11 +317,15 @@ replMakeAbsolute = \case
|
||||
invokeDir <- State.gets (^. replStateInvokeDir)
|
||||
return (invokeDir <//> r)
|
||||
|
||||
-- | imaginary file path for error messages in the repl.
|
||||
replPath :: Path Abs File
|
||||
replPath = $(mkAbsFile "/<repl>")
|
||||
|
||||
inferExpressionIO' :: ReplContext -> Text -> IO (Either JuvixError Internal.Expression)
|
||||
inferExpressionIO' ctx = inferExpressionIO "" (ctx ^. replContextExpContext) (ctx ^. replContextBuiltins)
|
||||
inferExpressionIO' ctx = inferExpressionIO replPath (ctx ^. replContextExpContext) (ctx ^. replContextBuiltins)
|
||||
|
||||
compileExpressionIO' :: ReplContext -> Text -> IO (Either JuvixError Core.Node)
|
||||
compileExpressionIO' ctx = compileExpressionIO "" (ctx ^. replContextExpContext) (ctx ^. replContextBuiltins)
|
||||
compileExpressionIO' ctx = compileExpressionIO replPath (ctx ^. replContextExpContext) (ctx ^. replContextBuiltins)
|
||||
|
||||
render' :: (P.HasAnsiBackend a, P.HasTextBackend a) => a -> Repl ()
|
||||
render' t = do
|
||||
|
@ -147,7 +147,7 @@ goStatement ::
|
||||
goStatement (Indexed idx s) =
|
||||
fmap (Indexed idx) <$> case s of
|
||||
StatementAxiom d -> Just . Abstract.StatementAxiom <$> goAxiom d
|
||||
StatementImport (Import t) -> Just . Abstract.StatementImport <$> goModule t
|
||||
StatementImport t -> Just . Abstract.StatementImport <$> goModule (t ^. importModule . moduleRefModule)
|
||||
StatementOperator {} -> return Nothing
|
||||
StatementOpenModule o -> goOpenModule o
|
||||
StatementInductive i -> Just . Abstract.StatementInductive <$> goInductive i
|
||||
@ -163,7 +163,7 @@ goOpenModule ::
|
||||
OpenModule 'Scoped ->
|
||||
Sem r (Maybe Abstract.Statement)
|
||||
goOpenModule o
|
||||
| o ^. openModuleImport =
|
||||
| isJust (o ^. openModuleImportKw) =
|
||||
case o ^. openModuleName of
|
||||
ModuleRef' (SModuleTop :&: m) ->
|
||||
Just . Abstract.StatementImport
|
||||
@ -179,13 +179,13 @@ goFunctionDef ::
|
||||
Sem r Abstract.FunctionDef
|
||||
goFunctionDef TypeSignature {..} clauses = do
|
||||
let _funDefName = goSymbol _sigName
|
||||
_funDefTerminating = _sigTerminating
|
||||
_funDefBuiltin = _sigBuiltin
|
||||
_funDefTerminating = isJust _sigTerminating
|
||||
_funDefBuiltin = (^. withLocParam) <$> _sigBuiltin
|
||||
_funDefClauses <- mapM goFunctionClause clauses
|
||||
_funDefTypeSig <- goExpression _sigType
|
||||
_funDefExamples <- goExamples _sigDoc
|
||||
let fun = Abstract.FunctionDef {..}
|
||||
whenJust _sigBuiltin (registerBuiltinFunction fun)
|
||||
whenJust _sigBuiltin (registerBuiltinFunction fun . (^. withLocParam))
|
||||
registerFunction' fun
|
||||
|
||||
goExamples ::
|
||||
@ -284,14 +284,14 @@ goInductive ty@InductiveDef {..} = do
|
||||
indDef =
|
||||
Abstract.InductiveDef
|
||||
{ _inductiveParameters = _inductiveParameters',
|
||||
_inductiveBuiltin = _inductiveBuiltin,
|
||||
_inductiveBuiltin = (^. withLocParam) <$> _inductiveBuiltin,
|
||||
_inductiveName = goSymbol _inductiveName,
|
||||
_inductiveType = fromMaybe (Abstract.ExpressionUniverse (smallUniverse loc)) _inductiveType',
|
||||
_inductiveConstructors = toList _inductiveConstructors',
|
||||
_inductiveExamples = _inductiveExamples',
|
||||
_inductivePositive = ty ^. inductivePositive
|
||||
}
|
||||
whenJust _inductiveBuiltin (registerBuiltinInductive indDef)
|
||||
whenJust ((^. withLocParam) <$> _inductiveBuiltin) (registerBuiltinInductive indDef)
|
||||
inductiveInfo <- registerInductive indDef
|
||||
forM_ _inductiveConstructors' (registerConstructor inductiveInfo)
|
||||
return (inductiveInfo ^. inductiveInfoDef)
|
||||
@ -351,8 +351,8 @@ goExpression = \case
|
||||
goSig sig = do
|
||||
_funDefClauses <- getClauses
|
||||
_funDefTypeSig <- goExpression (sig ^. sigType)
|
||||
let _funDefBuiltin = sig ^. sigBuiltin
|
||||
_funDefTerminating = sig ^. sigTerminating
|
||||
let _funDefBuiltin = (^. withLocParam) <$> sig ^. sigBuiltin
|
||||
_funDefTerminating = isJust (sig ^. sigTerminating)
|
||||
_funDefName = goSymbol (sig ^. sigName)
|
||||
_funDefExamples :: [Abstract.Example] = []
|
||||
registerFunction' Abstract.FunctionDef {..}
|
||||
@ -394,8 +394,8 @@ goExpression = \case
|
||||
r' <- goExpression r
|
||||
return (Abstract.Application l'' r' Explicit)
|
||||
|
||||
goLambda :: forall r. (Members '[Error ScoperError, InfoTableBuilder] r) => Lambda 'Scoped -> Sem r Abstract.Lambda
|
||||
goLambda (Lambda cl) = Abstract.Lambda <$> mapM goClause cl
|
||||
goLambda :: forall r. Members '[Error ScoperError, InfoTableBuilder] r => Lambda 'Scoped -> Sem r Abstract.Lambda
|
||||
goLambda l = Abstract.Lambda <$> mapM goClause (l ^. lambdaClauses)
|
||||
where
|
||||
goClause :: LambdaClause 'Scoped -> Sem r Abstract.LambdaClause
|
||||
goClause (LambdaClause ps b) = do
|
||||
@ -508,8 +508,8 @@ goAxiom a = do
|
||||
let axiom =
|
||||
Abstract.AxiomDef
|
||||
{ _axiomType = _axiomType',
|
||||
_axiomBuiltin = a ^. axiomBuiltin,
|
||||
_axiomBuiltin = (^. withLocParam) <$> a ^. axiomBuiltin,
|
||||
_axiomName = goSymbol (a ^. axiomName)
|
||||
}
|
||||
whenJust (a ^. axiomBuiltin) (registerBuiltinAxiom axiom)
|
||||
whenJust (a ^. axiomBuiltin) (registerBuiltinAxiom axiom . (^. withLocParam))
|
||||
registerAxiom' axiom
|
||||
|
@ -12,7 +12,7 @@ import Text.Megaparsec as P hiding (sepBy1, sepEndBy1, some)
|
||||
import Text.Megaparsec.Char.Lexer qualified as L
|
||||
|
||||
space :: ParsecS r ()
|
||||
space = space' False void
|
||||
space = void (space' False)
|
||||
|
||||
lexeme :: ParsecS r a -> ParsecS r a
|
||||
lexeme = L.lexeme space
|
||||
|
@ -487,7 +487,7 @@ goAxiom a
|
||||
defineName = mkName axiomName
|
||||
getCode :: BackendItem -> Maybe Text
|
||||
getCode b =
|
||||
guard (BackendC == b ^. backendItemBackend)
|
||||
guard (BackendC == b ^. backendItemBackend . withLocParam)
|
||||
$> b
|
||||
^. backendItemCode
|
||||
firstBackendMatch ::
|
||||
@ -518,7 +518,7 @@ goAxiom a
|
||||
return [ExternalFuncSig s]
|
||||
|
||||
goForeign :: ForeignBlock -> [CCode]
|
||||
goForeign b = case b ^. foreignBackend of
|
||||
goForeign b = case b ^. foreignBackend . withLocParam of
|
||||
BackendC -> [Verbatim (b ^. foreignCode)]
|
||||
_ -> []
|
||||
|
||||
|
@ -352,7 +352,7 @@ goJudoc (Judoc bs) = mconcatMapM goBlock bs
|
||||
JudocExample e -> goExample e
|
||||
|
||||
goLine :: JudocParagraphLine 'Scoped -> Sem r Html
|
||||
goLine (JudocParagraphLine atoms) = mconcatMapM goAtom (toList atoms)
|
||||
goLine (JudocParagraphLine atoms) = mconcatMapM goAtom (map (^. withLocParam) (toList atoms))
|
||||
|
||||
goExample :: Example 'Scoped -> Sem r Html
|
||||
goExample ex = do
|
||||
|
@ -21,6 +21,3 @@ filterInput absPth HighlightInput {..} =
|
||||
{ _highlightNames = filterByLoc absPth _highlightNames,
|
||||
_highlightParsed = filterByLoc absPth _highlightParsed
|
||||
}
|
||||
|
||||
filterByLoc :: (HasLoc p) => Path Abs File -> [p] -> [p]
|
||||
filterByLoc p = filter ((== toFilePath p) . (^. intervalFile) . getLoc)
|
||||
|
@ -41,7 +41,7 @@ instance ToJSON Face where
|
||||
|
||||
data PropertyGoto = PropertyGoto
|
||||
{ _gotoInterval :: Interval,
|
||||
_gotoFile :: FilePath,
|
||||
_gotoFile :: Path Abs File,
|
||||
_gotoPos :: FileLoc
|
||||
}
|
||||
|
||||
@ -61,12 +61,12 @@ data RawProperties = RawProperties
|
||||
}
|
||||
|
||||
-- | (File, Row, Col, Length)
|
||||
type RawInterval = (FilePath, Int, Int, Int)
|
||||
type RawInterval = (Path Abs File, Int, Int, Int)
|
||||
|
||||
type RawFace = (RawInterval, Face)
|
||||
|
||||
-- | (Interval, TargetFile, TargetLine, TargetColumn)
|
||||
type RawGoto = (RawInterval, FilePath, Int, Int)
|
||||
type RawGoto = (RawInterval, Path Abs File, Int, Int)
|
||||
|
||||
$( deriveToJSON
|
||||
defaultOptions
|
||||
@ -92,6 +92,7 @@ rawProperties Properties {..} =
|
||||
)
|
||||
rawFace :: PropertyFace -> RawFace
|
||||
rawFace PropertyFace {..} = (rawInterval _faceInterval, _faceFace)
|
||||
|
||||
rawGoto :: PropertyGoto -> RawGoto
|
||||
rawGoto PropertyGoto {..} =
|
||||
( rawInterval _gotoInterval,
|
||||
@ -125,7 +126,7 @@ instance ToSexp PropertyGoto where
|
||||
pos l = Int (succ (l ^. locOffset . unPos))
|
||||
start = pos (i ^. intervalStart)
|
||||
end = pos (i ^. intervalEnd)
|
||||
gotoPair = Pair (String targetFile) (Int (targetPos ^. locOffset . to (succ . fromIntegral)))
|
||||
gotoPair = Pair (String (toFilePath targetFile)) (Int (targetPos ^. locOffset . to (succ . fromIntegral)))
|
||||
|
||||
instance ToSexp Properties where
|
||||
toSexp Properties {..} =
|
||||
|
@ -2,7 +2,9 @@ module Juvix.Compiler.Concrete.Data.ModuleIsTop where
|
||||
|
||||
import Juvix.Prelude
|
||||
|
||||
data ModuleIsTop = ModuleTop | ModuleLocal
|
||||
data ModuleIsTop
|
||||
= ModuleTop
|
||||
| ModuleLocal
|
||||
deriving stock (Eq, Ord, Show)
|
||||
|
||||
$(genSingletons [''ModuleIsTop])
|
||||
|
@ -79,7 +79,12 @@ instance HasLoc TopModulePath where
|
||||
[] -> getLoc _modulePathName
|
||||
(x : _) -> getLoc x <> getLoc _modulePathName
|
||||
|
||||
topModulePathToDottedPath :: (IsString s) => TopModulePath -> s
|
||||
topModulePathToName :: TopModulePath -> Name
|
||||
topModulePathToName (TopModulePath ms m) = case nonEmpty ms of
|
||||
Nothing -> NameUnqualified m
|
||||
Just ms' -> NameQualified (QualifiedName (SymbolPath ms') m)
|
||||
|
||||
topModulePathToDottedPath :: IsString s => TopModulePath -> s
|
||||
topModulePathToDottedPath (TopModulePath l r) =
|
||||
fromText $ mconcat $ intersperse "." $ map (^. symbolText) $ l ++ [r]
|
||||
|
||||
|
@ -19,7 +19,10 @@ newtype AxiomRef' (n :: S.IsConcrete) = AxiomRef'
|
||||
|
||||
makeLenses ''AxiomRef'
|
||||
|
||||
instance (Hashable (RefNameType s)) => Hashable (AxiomRef' s) where
|
||||
instance HasLoc AxiomRef where
|
||||
getLoc = getLoc . (^. axiomRefName)
|
||||
|
||||
instance Hashable (RefNameType s) => Hashable (AxiomRef' s) where
|
||||
hashWithSalt i = hashWithSalt i . (^. axiomRefName)
|
||||
|
||||
instance (Eq (RefNameType s)) => Eq (AxiomRef' s) where
|
||||
@ -39,7 +42,10 @@ newtype InductiveRef' (n :: S.IsConcrete) = InductiveRef'
|
||||
|
||||
makeLenses ''InductiveRef'
|
||||
|
||||
instance (Hashable (RefNameType s)) => Hashable (InductiveRef' s) where
|
||||
instance HasLoc InductiveRef where
|
||||
getLoc = getLoc . (^. inductiveRefName)
|
||||
|
||||
instance Hashable (RefNameType s) => Hashable (InductiveRef' s) where
|
||||
hashWithSalt i = hashWithSalt i . (^. inductiveRefName)
|
||||
|
||||
instance (Eq (RefNameType s)) => Eq (InductiveRef' s) where
|
||||
@ -59,7 +65,10 @@ newtype FunctionRef' (n :: S.IsConcrete) = FunctionRef'
|
||||
|
||||
makeLenses ''FunctionRef'
|
||||
|
||||
instance (Hashable (RefNameType s)) => Hashable (FunctionRef' s) where
|
||||
instance HasLoc FunctionRef where
|
||||
getLoc = getLoc . (^. functionRefName)
|
||||
|
||||
instance Hashable (RefNameType s) => Hashable (FunctionRef' s) where
|
||||
hashWithSalt i = hashWithSalt i . (^. functionRefName)
|
||||
|
||||
instance (Eq (RefNameType s)) => Eq (FunctionRef' s) where
|
||||
@ -79,7 +88,10 @@ newtype ConstructorRef' (n :: S.IsConcrete) = ConstructorRef'
|
||||
|
||||
makeLenses ''ConstructorRef'
|
||||
|
||||
instance (Hashable (RefNameType s)) => Hashable (ConstructorRef' s) where
|
||||
instance HasLoc ConstructorRef where
|
||||
getLoc = getLoc . (^. constructorRefName)
|
||||
|
||||
instance Hashable (RefNameType s) => Hashable (ConstructorRef' s) where
|
||||
hashWithSalt i = hashWithSalt i . (^. constructorRefName)
|
||||
|
||||
instance (Eq (RefNameType s)) => Eq (ConstructorRef' s) where
|
||||
@ -90,6 +102,3 @@ instance (Ord (RefNameType s)) => Ord (ConstructorRef' s) where
|
||||
|
||||
instance (Show (RefNameType s)) => Show (ConstructorRef' s) where
|
||||
show = show . (^. constructorRefName)
|
||||
|
||||
instance HasLoc (ConstructorRef' 'S.Concrete) where
|
||||
getLoc (ConstructorRef' c) = getLoc c
|
||||
|
@ -1,12 +1,13 @@
|
||||
module Juvix.Compiler.Concrete.Data.ParsedInfoTable where
|
||||
|
||||
import Juvix.Compiler.Concrete.Data.ParsedItem
|
||||
import Juvix.Data.Comment
|
||||
import Juvix.Prelude
|
||||
|
||||
newtype InfoTable = InfoTable
|
||||
{ _infoParsedItems :: [ParsedItem]
|
||||
data InfoTable = InfoTable
|
||||
{ _infoParsedItems :: [ParsedItem],
|
||||
_infoParsedComments :: Comments
|
||||
}
|
||||
deriving newtype (Semigroup, Monoid)
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
makeLenses ''InfoTable
|
||||
|
@ -2,6 +2,7 @@ module Juvix.Compiler.Concrete.Data.ParsedInfoTableBuilder
|
||||
( InfoTableBuilder,
|
||||
registerLiteral,
|
||||
registerKeyword,
|
||||
registerJudocText,
|
||||
registerComment,
|
||||
mergeTable,
|
||||
runInfoTableBuilder,
|
||||
@ -13,31 +14,35 @@ where
|
||||
import Juvix.Compiler.Concrete.Data.Literal
|
||||
import Juvix.Compiler.Concrete.Data.ParsedInfoTable
|
||||
import Juvix.Compiler.Concrete.Data.ParsedItem
|
||||
import Juvix.Data.Comment
|
||||
import Juvix.Data.Keyword
|
||||
import Juvix.Prelude
|
||||
|
||||
data InfoTableBuilder m a where
|
||||
RegisterItem :: ParsedItem -> InfoTableBuilder m ()
|
||||
RegisterComment :: Comment -> InfoTableBuilder m ()
|
||||
MergeTable :: InfoTable -> InfoTableBuilder m ()
|
||||
|
||||
makeSem ''InfoTableBuilder
|
||||
|
||||
registerComment :: (Member InfoTableBuilder r) => Interval -> Sem r ()
|
||||
registerComment i =
|
||||
registerKeyword :: Member InfoTableBuilder r => KeywordRef -> Sem r KeywordRef
|
||||
registerKeyword r =
|
||||
r
|
||||
<$ registerItem
|
||||
ParsedItem
|
||||
{ _parsedLoc = getLoc r,
|
||||
_parsedTag = ParsedTagKeyword
|
||||
}
|
||||
|
||||
registerJudocText :: Member InfoTableBuilder r => Interval -> Sem r ()
|
||||
registerJudocText i =
|
||||
registerItem
|
||||
ParsedItem
|
||||
{ _parsedLoc = i,
|
||||
_parsedTag = ParsedTagComment
|
||||
}
|
||||
|
||||
registerKeyword :: (Member InfoTableBuilder r) => Interval -> Sem r ()
|
||||
registerKeyword i =
|
||||
registerItem
|
||||
ParsedItem
|
||||
{ _parsedLoc = i,
|
||||
_parsedTag = ParsedTagKeyword
|
||||
}
|
||||
|
||||
registerLiteral :: (Member InfoTableBuilder r) => LiteralLoc -> Sem r LiteralLoc
|
||||
registerLiteral :: Member InfoTableBuilder r => LiteralLoc -> Sem r LiteralLoc
|
||||
registerLiteral l =
|
||||
l
|
||||
<$ registerItem
|
||||
@ -51,8 +56,9 @@ registerLiteral l =
|
||||
LitInteger {} -> ParsedTagLiteralInt
|
||||
loc = getLoc l
|
||||
|
||||
newtype BuilderState = BuilderState
|
||||
{ _stateItems :: [ParsedItem]
|
||||
data BuilderState = BuilderState
|
||||
{ _stateItems :: [ParsedItem],
|
||||
_stateComments :: [Comment]
|
||||
}
|
||||
deriving stock (Show)
|
||||
|
||||
@ -61,11 +67,19 @@ makeLenses ''BuilderState
|
||||
iniState :: BuilderState
|
||||
iniState =
|
||||
BuilderState
|
||||
{ _stateItems = []
|
||||
{ _stateItems = [],
|
||||
_stateComments = []
|
||||
}
|
||||
|
||||
build :: BuilderState -> InfoTable
|
||||
build st = InfoTable (nubHashable (st ^. stateItems))
|
||||
build st =
|
||||
InfoTable
|
||||
{ _infoParsedItems = nubHashable (st ^. stateItems),
|
||||
_infoParsedComments = mkComments (st ^. stateComments)
|
||||
}
|
||||
|
||||
registerItem' :: Members '[State BuilderState] r => ParsedItem -> Sem r ()
|
||||
registerItem' i = modify' (over stateItems (i :))
|
||||
|
||||
runInfoTableBuilder :: Sem (InfoTableBuilder ': r) a -> Sem r (InfoTable, a)
|
||||
runInfoTableBuilder =
|
||||
@ -75,8 +89,16 @@ runInfoTableBuilder =
|
||||
( \case
|
||||
RegisterItem i ->
|
||||
modify' (over stateItems (i :))
|
||||
MergeTable tbl ->
|
||||
MergeTable tbl -> do
|
||||
modify' (over stateItems ((tbl ^. infoParsedItems) <>))
|
||||
modify' (over stateComments (allComments (tbl ^. infoParsedComments) <>))
|
||||
RegisterComment c -> do
|
||||
modify' (over stateComments (c :))
|
||||
registerItem'
|
||||
ParsedItem
|
||||
{ _parsedLoc = c ^. commentInterval,
|
||||
_parsedTag = ParsedTagComment
|
||||
}
|
||||
)
|
||||
|
||||
ignoreInfoTableBuilder :: Sem (InfoTableBuilder ': r) a -> Sem r a
|
||||
|
@ -17,7 +17,9 @@ import Juvix.Prelude.Pretty
|
||||
-- Names
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data IsConcrete = NotConcrete | Concrete
|
||||
data IsConcrete
|
||||
= NotConcrete
|
||||
| Concrete
|
||||
|
||||
$(genSingletons [''IsConcrete])
|
||||
|
||||
|
@ -3,7 +3,6 @@ module Juvix.Compiler.Concrete.Extra
|
||||
mkScopedModule,
|
||||
getAllModules,
|
||||
getModuleFilePath,
|
||||
getModuleFileAbsPath,
|
||||
unfoldApplication,
|
||||
)
|
||||
where
|
||||
@ -39,7 +38,7 @@ getAllModules' m = recordModule m
|
||||
|
||||
processStatement :: Statement 'Scoped -> Sem r ()
|
||||
processStatement = \case
|
||||
StatementImport (Import n) -> recordModule n
|
||||
StatementImport i -> recordModule (i ^. importModule . moduleRefModule)
|
||||
StatementModule n -> processModule (mkScopedModule n)
|
||||
StatementOpenModule n -> forM_ (getModuleRefTopModule (n ^. openModuleName)) recordModule
|
||||
_ -> return ()
|
||||
@ -49,12 +48,9 @@ getAllModules' m = recordModule m
|
||||
SModuleLocal -> Nothing
|
||||
SModuleTop -> Just _moduleRefModule
|
||||
|
||||
getModuleFilePath :: Module 'Scoped 'ModuleTop -> FilePath
|
||||
getModuleFilePath :: Module 'Scoped 'ModuleTop -> Path Abs File
|
||||
getModuleFilePath m = getLoc (m ^. modulePath) ^. intervalFile
|
||||
|
||||
getModuleFileAbsPath :: FilePath -> Module 'Scoped 'ModuleTop -> FilePath
|
||||
getModuleFileAbsPath root m = normalise (root </> getModuleFilePath m)
|
||||
|
||||
unfoldApplication :: Application -> (Expression, [Expression])
|
||||
unfoldApplication (Application l r) = go [r] l
|
||||
where
|
||||
|
@ -27,6 +27,7 @@ import Juvix.Compiler.Concrete.Data.VisibilityAnn
|
||||
import Juvix.Data
|
||||
import Juvix.Data.Ape.Base as Ape
|
||||
import Juvix.Data.Fixity
|
||||
import Juvix.Data.Keyword
|
||||
import Juvix.Data.NameKind
|
||||
import Juvix.Prelude hiding (show)
|
||||
import Prelude (show)
|
||||
@ -89,7 +90,7 @@ type family PatternAtType s = res | res -> s where
|
||||
|
||||
type family ImportType (s :: Stage) :: GHC.Type where
|
||||
ImportType 'Parsed = TopModulePath
|
||||
ImportType 'Scoped = Module 'Scoped 'ModuleTop
|
||||
ImportType 'Scoped = ModuleRef'' 'S.Concrete 'ModuleTop
|
||||
|
||||
type ModulePathType :: Stage -> ModuleIsTop -> GHC.Type
|
||||
type family ModulePathType s t = res | res -> t s where
|
||||
@ -151,8 +152,9 @@ deriving stock instance
|
||||
-- Import statement
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
newtype Import (s :: Stage) = Import
|
||||
{ _importModule :: ImportType s
|
||||
data Import (s :: Stage) = Import
|
||||
{ _importKw :: KeywordRef,
|
||||
_importModule :: ImportType s
|
||||
}
|
||||
|
||||
deriving stock instance (Show (ImportType s)) => Show (Import s)
|
||||
@ -161,21 +163,19 @@ deriving stock instance (Eq (ImportType s)) => Eq (Import s)
|
||||
|
||||
deriving stock instance (Ord (ImportType s)) => Ord (Import s)
|
||||
|
||||
instance HasLoc (Import 'Parsed) where
|
||||
getLoc (Import t) = getLoc t
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Operator syntax declaration
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data OperatorSyntaxDef = OperatorSyntaxDef
|
||||
{ _opSymbol :: Symbol,
|
||||
_opFixity :: Fixity
|
||||
_opFixity :: Fixity,
|
||||
_opKw :: KeywordRef
|
||||
}
|
||||
deriving stock (Show, Eq, Ord)
|
||||
|
||||
instance HasLoc OperatorSyntaxDef where
|
||||
getLoc OperatorSyntaxDef {..} = getLoc _opSymbol
|
||||
getLoc OperatorSyntaxDef {..} = getLoc _opKw <> getLoc _opSymbol
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Type signature declaration
|
||||
@ -185,8 +185,8 @@ data TypeSignature (s :: Stage) = TypeSignature
|
||||
{ _sigName :: FunctionName s,
|
||||
_sigType :: ExpressionType s,
|
||||
_sigDoc :: Maybe (Judoc s),
|
||||
_sigBuiltin :: Maybe BuiltinFunction,
|
||||
_sigTerminating :: Bool
|
||||
_sigBuiltin :: Maybe (WithLoc BuiltinFunction),
|
||||
_sigTerminating :: Maybe KeywordRef
|
||||
}
|
||||
|
||||
deriving stock instance (Show (ExpressionType s), Show (SymbolType s)) => Show (TypeSignature s)
|
||||
@ -200,9 +200,10 @@ deriving stock instance (Ord (ExpressionType s), Ord (SymbolType s)) => Ord (Typ
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
data AxiomDef (s :: Stage) = AxiomDef
|
||||
{ _axiomDoc :: Maybe (Judoc s),
|
||||
{ _axiomKw :: KeywordRef,
|
||||
_axiomDoc :: Maybe (Judoc s),
|
||||
_axiomName :: SymbolType s,
|
||||
_axiomBuiltin :: Maybe BuiltinAxiom,
|
||||
_axiomBuiltin :: Maybe (WithLoc BuiltinAxiom),
|
||||
_axiomType :: ExpressionType s
|
||||
}
|
||||
|
||||
@ -244,7 +245,8 @@ deriving stock instance (Eq (ExpressionType s), Eq (SymbolType s)) => Eq (Induct
|
||||
deriving stock instance (Ord (ExpressionType s), Ord (SymbolType s)) => Ord (InductiveParameter s)
|
||||
|
||||
data InductiveDef (s :: Stage) = InductiveDef
|
||||
{ _inductiveBuiltin :: Maybe BuiltinInductive,
|
||||
{ _inductiveKw :: KeywordRef,
|
||||
_inductiveBuiltin :: Maybe (WithLoc BuiltinInductive),
|
||||
_inductiveDoc :: Maybe (Judoc s),
|
||||
_inductiveName :: InductiveName s,
|
||||
_inductiveParameters :: [InductiveParameter s],
|
||||
@ -388,7 +390,8 @@ deriving stock instance
|
||||
type LocalModuleName s = SymbolType s
|
||||
|
||||
data Module (s :: Stage) (t :: ModuleIsTop) = Module
|
||||
{ _modulePath :: ModulePathType s t,
|
||||
{ _moduleKw :: KeywordRef,
|
||||
_modulePath :: ModulePathType s t,
|
||||
_moduleParameters :: [InductiveParameter s],
|
||||
_moduleDoc :: Maybe (Judoc s),
|
||||
_moduleBody :: [Statement s]
|
||||
@ -461,11 +464,19 @@ getModuleExportInfo (ModuleRef' (_ :&: ModuleRef'' {..})) = _moduleExportInfo
|
||||
getModuleRefNameType :: ModuleRef' c -> RefNameType c
|
||||
getModuleRefNameType (ModuleRef' (_ :&: ModuleRef'' {..})) = _moduleRefName
|
||||
|
||||
instance (SingI c) => Eq (ModuleRef' c) where
|
||||
(==) = (==) `on` (getNameRefId . getModuleRefNameType)
|
||||
getModuleRefNameId :: forall c. SingI c => ModuleRef' c -> S.NameId
|
||||
getModuleRefNameId (ModuleRef' (t :&: ModuleRef'' {..})) =
|
||||
case sing :: S.SIsConcrete c of
|
||||
S.SConcrete -> case t of
|
||||
SModuleTop -> _moduleRefName ^. S.nameId
|
||||
SModuleLocal -> _moduleRefName ^. S.nameId
|
||||
S.SNotConcrete -> _moduleRefName ^. S.nameId
|
||||
|
||||
instance (SingI c) => Ord (ModuleRef' c) where
|
||||
compare = compare `on` (getNameRefId . getModuleRefNameType)
|
||||
instance SingI c => Eq (ModuleRef' c) where
|
||||
(==) = (==) `on` getModuleRefNameId
|
||||
|
||||
instance SingI c => Ord (ModuleRef' c) where
|
||||
compare = compare `on` getModuleRefNameId
|
||||
|
||||
data ModuleRef'' (c :: S.IsConcrete) (t :: ModuleIsTop) = ModuleRef''
|
||||
{ _moduleRefName :: RefNameType c,
|
||||
@ -491,8 +502,9 @@ newtype ExportInfo = ExportInfo
|
||||
deriving stock (Show)
|
||||
|
||||
data OpenModule (s :: Stage) = OpenModule
|
||||
{ _openModuleName :: ModuleRefType s,
|
||||
_openModuleImport :: Bool,
|
||||
{ _openModuleKw :: KeywordRef,
|
||||
_openModuleName :: ModuleRefType s,
|
||||
_openModuleImportKw :: Maybe KeywordRef,
|
||||
_openParameters :: [ExpressionType s],
|
||||
_openUsingHiding :: Maybe UsingHiding,
|
||||
_openPublic :: PublicAnn
|
||||
@ -573,27 +585,9 @@ data Expression
|
||||
| ExpressionBraces (WithLoc Expression)
|
||||
deriving stock (Show, Eq, Ord)
|
||||
|
||||
instance HasAtomicity (LetBlock 'Scoped) where
|
||||
atomicity (LetBlock _ e) = atomicity e
|
||||
|
||||
instance HasAtomicity (Lambda s) where
|
||||
atomicity = const Atom
|
||||
|
||||
instance HasAtomicity Expression where
|
||||
atomicity e = case e of
|
||||
ExpressionIdentifier {} -> Atom
|
||||
ExpressionHole {} -> Atom
|
||||
ExpressionParensIdentifier {} -> Atom
|
||||
ExpressionApplication {} -> Aggregate appFixity
|
||||
ExpressionInfixApplication a -> Aggregate (getFixity a)
|
||||
ExpressionPostfixApplication a -> Aggregate (getFixity a)
|
||||
ExpressionLambda l -> atomicity l
|
||||
ExpressionLiteral l -> atomicity l
|
||||
ExpressionLetBlock l -> atomicity l
|
||||
ExpressionBraces {} -> Atom
|
||||
ExpressionUniverse {} -> Atom
|
||||
ExpressionFunction {} -> Aggregate funFixity
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Function expression
|
||||
--------------------------------------------------------------------------------
|
||||
@ -635,8 +629,9 @@ deriving stock instance (Ord (ExpressionType s), Ord (SymbolType s)) => Ord (Fun
|
||||
-- Notes: An empty lambda, here called 'the impossible case', is a lambda
|
||||
-- expression with empty list of arguments and empty body.
|
||||
|
||||
newtype Lambda (s :: Stage) = Lambda
|
||||
{ _lambdaClauses :: [LambdaClause s]
|
||||
data Lambda (s :: Stage) = Lambda
|
||||
{ _lambdaKw :: KeywordRef,
|
||||
_lambdaClauses :: [LambdaClause s]
|
||||
}
|
||||
|
||||
deriving stock instance
|
||||
@ -714,7 +709,8 @@ instance HasFixity PostfixApplication where
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data LetBlock (s :: Stage) = LetBlock
|
||||
{ _letClauses :: NonEmpty (LetClause s),
|
||||
{ _letKw :: KeywordRef,
|
||||
_letClauses :: NonEmpty (LetClause s),
|
||||
_letExpression :: ExpressionType s
|
||||
}
|
||||
|
||||
@ -781,7 +777,8 @@ deriving stock instance
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data Compile s = Compile
|
||||
{ _compileName :: SymbolType s,
|
||||
{ _compileKw :: KeywordRef,
|
||||
_compileName :: SymbolType s,
|
||||
_compileBackendItems :: [BackendItem]
|
||||
}
|
||||
|
||||
@ -857,6 +854,7 @@ deriving stock instance (Ord (ExpressionType s), Ord (SymbolType s)) => Ord (Jud
|
||||
|
||||
data Example (s :: Stage) = Example
|
||||
{ _exampleId :: NameId,
|
||||
_exampleLoc :: Interval,
|
||||
_exampleExpression :: ExpressionType s
|
||||
}
|
||||
|
||||
@ -877,7 +875,7 @@ deriving stock instance (Eq (ExpressionType s), Eq (SymbolType s)) => Eq (JudocB
|
||||
deriving stock instance (Ord (ExpressionType s), Ord (SymbolType s)) => Ord (JudocBlock s)
|
||||
|
||||
newtype JudocParagraphLine (s :: Stage)
|
||||
= JudocParagraphLine (NonEmpty (JudocAtom s))
|
||||
= JudocParagraphLine (NonEmpty (WithLoc (JudocAtom s)))
|
||||
|
||||
deriving stock instance (Show (ExpressionType s), Show (SymbolType s)) => Show (JudocParagraphLine s)
|
||||
|
||||
@ -897,6 +895,8 @@ deriving stock instance (Ord (ExpressionType s), Ord (SymbolType s)) => Ord (Jud
|
||||
|
||||
makeLenses ''PatternArg
|
||||
makeLenses ''Example
|
||||
makeLenses ''Lambda
|
||||
makeLenses ''LambdaClause
|
||||
makeLenses ''Judoc
|
||||
makeLenses ''Function
|
||||
makeLenses ''InductiveDef
|
||||
@ -924,6 +924,27 @@ makeLenses ''PatternBinding
|
||||
makeLenses ''PatternAtoms
|
||||
makeLenses ''ExpressionAtoms
|
||||
|
||||
instance HasAtomicity Expression where
|
||||
atomicity e = case e of
|
||||
ExpressionIdentifier {} -> Atom
|
||||
ExpressionHole {} -> Atom
|
||||
ExpressionParensIdentifier {} -> Atom
|
||||
ExpressionApplication {} -> Aggregate appFixity
|
||||
ExpressionInfixApplication a -> Aggregate (getFixity a)
|
||||
ExpressionPostfixApplication a -> Aggregate (getFixity a)
|
||||
ExpressionLambda l -> atomicity l
|
||||
ExpressionLiteral l -> atomicity l
|
||||
ExpressionLetBlock l -> atomicity l
|
||||
ExpressionBraces {} -> Atom
|
||||
ExpressionUniverse {} -> Atom
|
||||
ExpressionFunction {} -> Aggregate funFixity
|
||||
|
||||
instance HasAtomicity (LetBlock 'Scoped) where
|
||||
atomicity l = atomicity (l ^. letExpression)
|
||||
|
||||
instance Eq (ModuleRef'' 'S.Concrete t) where
|
||||
(==) = (==) `on` (^. moduleRefName)
|
||||
|
||||
instance HasAtomicity (PatternAtom 'Parsed) where
|
||||
atomicity = const Atom
|
||||
|
||||
@ -978,6 +999,81 @@ deriving stock instance
|
||||
deriving stock instance
|
||||
(Show (PatternAtom s)) => Show (PatternAtoms s)
|
||||
|
||||
instance HasLoc ScopedIden where
|
||||
getLoc = \case
|
||||
ScopedAxiom a -> getLoc a
|
||||
ScopedConstructor a -> getLoc a
|
||||
ScopedInductive a -> getLoc a
|
||||
ScopedFunction a -> getLoc a
|
||||
ScopedVar a -> getLoc a
|
||||
|
||||
instance HasLoc Application where
|
||||
getLoc (Application l r) = getLoc l <> getLoc r
|
||||
|
||||
instance HasLoc InfixApplication where
|
||||
getLoc (InfixApplication l _ r) = getLoc l <> getLoc r
|
||||
|
||||
instance HasLoc PostfixApplication where
|
||||
getLoc (PostfixApplication l o) = getLoc l <> getLoc o
|
||||
|
||||
instance HasLoc (LambdaClause 'Scoped) where
|
||||
getLoc c = getLocSpan (c ^. lambdaParameters) <> getLoc (c ^. lambdaBody)
|
||||
|
||||
instance HasLoc (Lambda 'Scoped) where
|
||||
getLoc l = getLoc (l ^. lambdaKw) <>? (getLocSpan <$> nonEmpty (l ^. lambdaClauses))
|
||||
|
||||
instance HasLoc (FunctionParameter 'Scoped) where
|
||||
getLoc p = (getLoc <$> p ^. paramName) ?<> getLoc (p ^. paramType)
|
||||
|
||||
instance HasLoc (Function 'Scoped) where
|
||||
getLoc f = getLoc (f ^. funParameter) <> getLoc (f ^. funReturn)
|
||||
|
||||
instance HasLoc (LetBlock 'Scoped) where
|
||||
getLoc l = getLoc (l ^. letKw) <> getLoc (l ^. letExpression)
|
||||
|
||||
instance HasLoc Expression where
|
||||
getLoc = \case
|
||||
ExpressionIdentifier i -> getLoc i
|
||||
ExpressionParensIdentifier i -> getLoc i
|
||||
ExpressionApplication i -> getLoc i
|
||||
ExpressionInfixApplication i -> getLoc i
|
||||
ExpressionPostfixApplication i -> getLoc i
|
||||
ExpressionLambda i -> getLoc i
|
||||
ExpressionLetBlock i -> getLoc i
|
||||
ExpressionUniverse i -> getLoc i
|
||||
ExpressionLiteral i -> getLoc i
|
||||
ExpressionFunction i -> getLoc i
|
||||
ExpressionHole i -> getLoc i
|
||||
ExpressionBraces i -> getLoc i
|
||||
|
||||
instance SingI s => HasLoc (Import s) where
|
||||
getLoc Import {..} = case sing :: SStage s of
|
||||
SParsed -> getLoc _importModule
|
||||
SScoped -> getLoc _importModule
|
||||
|
||||
instance HasLoc (ModuleRef'' 'S.Concrete t) where
|
||||
getLoc ref = getLoc (ref ^. moduleRefName)
|
||||
|
||||
instance (SingI s, SingI t) => HasLoc (Module s t) where
|
||||
getLoc m = case sing :: SStage s of
|
||||
SParsed -> case sing :: SModuleIsTop t of
|
||||
SModuleLocal -> getLoc (m ^. modulePath)
|
||||
SModuleTop -> getLoc (m ^. modulePath)
|
||||
SScoped -> case sing :: SModuleIsTop t of
|
||||
SModuleLocal -> getLoc (m ^. modulePath)
|
||||
SModuleTop -> getLoc (m ^. modulePath)
|
||||
|
||||
instance HasLoc (Example s) where
|
||||
getLoc e = e ^. exampleLoc
|
||||
|
||||
instance HasLoc (JudocBlock s) where
|
||||
getLoc = \case
|
||||
JudocParagraph ls -> getLocSpan ls
|
||||
JudocExample e -> getLoc e
|
||||
|
||||
instance HasLoc (JudocParagraphLine s) where
|
||||
getLoc (JudocParagraphLine atoms) = getLocSpan atoms
|
||||
|
||||
instance HasLoc PatternScopedIden where
|
||||
getLoc = \case
|
||||
PatternScopedVar v -> getLoc v
|
||||
|
@ -7,13 +7,14 @@ where
|
||||
|
||||
import Data.List.NonEmpty.Extra qualified as NonEmpty
|
||||
import Data.Text qualified as T
|
||||
import Juvix.Compiler.Concrete.Data.ScopedName (AbsModulePath)
|
||||
import Juvix.Compiler.Concrete.Data.ScopedName (AbsModulePath, IsConcrete (..))
|
||||
import Juvix.Compiler.Concrete.Data.ScopedName qualified as S
|
||||
import Juvix.Compiler.Concrete.Extra (unfoldApplication)
|
||||
import Juvix.Compiler.Concrete.Language
|
||||
import Juvix.Compiler.Concrete.Pretty.Options
|
||||
import Juvix.Data.Ape
|
||||
import Juvix.Data.CodeAnn
|
||||
import Juvix.Data.Keyword
|
||||
import Juvix.Extra.Strings qualified as Str
|
||||
import Juvix.Prelude
|
||||
import Juvix.Prelude.Pretty qualified as PP
|
||||
@ -76,10 +77,10 @@ groupStatements = reverse . map reverse . uncurry cons . foldl' aux ([], [])
|
||||
SScoped ->
|
||||
i
|
||||
^. importModule
|
||||
. moduleRefModule
|
||||
. modulePath
|
||||
. S.nameId
|
||||
== projSigma2 (^. moduleRefName) (o ^. openModuleName . unModuleRef')
|
||||
^. S.nameId
|
||||
== getModuleRefNameId (o ^. openModuleName)
|
||||
(StatementImport _, _) -> False
|
||||
(StatementOpenModule {}, StatementOpenModule {}) -> True
|
||||
(StatementOpenModule {}, _) -> False
|
||||
@ -319,7 +320,13 @@ ppName = case sing :: SStage s of
|
||||
instance PrettyCode S.NameId where
|
||||
ppCode (S.NameId k) = return (pretty k)
|
||||
|
||||
annDef :: forall s. (SingI s) => SymbolType s -> Doc Ann -> Doc Ann
|
||||
instance PrettyCode KeywordRef where
|
||||
ppCode = return . annotate AnnKeyword . pretty
|
||||
|
||||
instance PrettyCode Keyword where
|
||||
ppCode = return . annotate AnnKeyword . pretty
|
||||
|
||||
annDef :: forall s. SingI s => SymbolType s -> Doc Ann -> Doc Ann
|
||||
annDef nm = case sing :: SStage s of
|
||||
SScoped -> annSDef nm
|
||||
SParsed -> id
|
||||
@ -353,7 +360,9 @@ instance (PrettyCode n) => PrettyCode (S.Name' n) where
|
||||
annSRef = annotate (AnnRef (_nameDefinedIn ^. S.absTopModulePath) _nameId)
|
||||
|
||||
instance PrettyCode ModuleRef where
|
||||
ppCode = ppCode . projSigma2 (^. moduleRefName) . (^. unModuleRef')
|
||||
ppCode (ModuleRef' (t :&: ModuleRef'' {..})) = case t of
|
||||
SModuleTop -> ppCode _moduleRefName
|
||||
SModuleLocal -> ppCode _moduleRefName
|
||||
|
||||
instance (SingI s) => PrettyCode (OpenModule s) where
|
||||
ppCode :: forall r. (Members '[Reader Options] r) => OpenModule s -> Sem r (Doc Ann)
|
||||
@ -363,11 +372,9 @@ instance (SingI s) => PrettyCode (OpenModule s) where
|
||||
SScoped -> ppCode _openModuleName
|
||||
openUsingHiding' <- mapM ppUsingHiding _openUsingHiding
|
||||
openParameters' <- ppOpenParams
|
||||
importkw' <- mapM ppCode _openModuleImportKw
|
||||
let openPublic' = ppPublic
|
||||
import_
|
||||
| _openModuleImport = Just kwImport
|
||||
| otherwise = Nothing
|
||||
return $ kwOpen <+?> import_ <+> openModuleName' <+?> openParameters' <+?> openUsingHiding' <+?> openPublic'
|
||||
return $ kwOpen <+?> importkw' <+> openModuleName' <+?> openParameters' <+?> openUsingHiding' <+?> openPublic'
|
||||
where
|
||||
ppAtom' = case sing :: SStage s of
|
||||
SParsed -> ppCodeAtom
|
||||
@ -432,7 +439,7 @@ instance (SingI s) => PrettyCode (JudocAtom s) where
|
||||
|
||||
instance (SingI s) => PrettyCode (TypeSignature s) where
|
||||
ppCode TypeSignature {..} = do
|
||||
let sigTerminating' = if _sigTerminating then kwTerminating <> line else mempty
|
||||
let sigTerminating' = if isJust _sigTerminating then kwTerminating <> line else mempty
|
||||
sigName' <- annDef _sigName <$> ppSymbol _sigName
|
||||
sigType' <- ppExpression _sigType
|
||||
builtin' <- traverse ppCode _sigBuiltin
|
||||
@ -519,26 +526,20 @@ instance (SingI s) => PrettyCode (AxiomDef s) where
|
||||
builtin' <- traverse ppCode _axiomBuiltin
|
||||
return $ axiomDoc' ?<> builtin' <?+> hang' (kwAxiom <+> axiomName' <+> kwColon <+> axiomType')
|
||||
|
||||
instance (SingI s) => PrettyCode (Import s) where
|
||||
ppCode :: forall r. (Members '[Reader Options] r) => Import s -> Sem r (Doc Ann)
|
||||
ppCode (Import m) = do
|
||||
instance SingI s => PrettyCode (Import s) where
|
||||
ppCode :: forall r. Members '[Reader Options] r => Import s -> Sem r (Doc Ann)
|
||||
ppCode i = do
|
||||
modulePath' <- ppModulePath
|
||||
inlineImport' <- inlineImport
|
||||
return $ kwImport <+> modulePath' <+?> inlineImport'
|
||||
return $ kwImport <+> modulePath'
|
||||
where
|
||||
ppModulePath = case sing :: SStage s of
|
||||
SParsed -> ppCode m
|
||||
SScoped -> ppTopModulePath (m ^. modulePath)
|
||||
jumpLines :: Doc Ann -> Doc Ann
|
||||
jumpLines x = line <> x <> line
|
||||
inlineImport :: Sem r (Maybe (Doc Ann))
|
||||
inlineImport = do
|
||||
b <- asks (^. optInlineImports)
|
||||
if b
|
||||
then case sing :: SStage s of
|
||||
SParsed -> return Nothing
|
||||
SScoped -> Just . braces . jumpLines . indent' <$> ppCode m
|
||||
else return Nothing
|
||||
SParsed -> ppCode (i ^. importModule)
|
||||
SScoped -> ppCode (i ^. importModule)
|
||||
|
||||
instance SingI t => PrettyCode (ModuleRef'' 'Concrete t) where
|
||||
ppCode m = case sing :: SModuleIsTop t of
|
||||
SModuleTop -> ppCode (m ^. moduleRefName)
|
||||
SModuleLocal -> ppCode (m ^. moduleRefName)
|
||||
|
||||
instance PrettyCode PatternScopedIden where
|
||||
ppCode = \case
|
||||
|
@ -4,7 +4,6 @@ import Juvix.Prelude
|
||||
|
||||
data Options = Options
|
||||
{ _optShowNameIds :: Bool,
|
||||
_optInlineImports :: Bool,
|
||||
_optNoApe :: Bool
|
||||
}
|
||||
|
||||
@ -12,7 +11,6 @@ defaultOptions :: Options
|
||||
defaultOptions =
|
||||
Options
|
||||
{ _optShowNameIds = False,
|
||||
_optInlineImports = False,
|
||||
_optNoApe = False
|
||||
}
|
||||
|
||||
|
18
src/Juvix/Compiler/Concrete/Print.hs
Normal file
18
src/Juvix/Compiler/Concrete/Print.hs
Normal file
@ -0,0 +1,18 @@
|
||||
module Juvix.Compiler.Concrete.Print
|
||||
( module Juvix.Compiler.Concrete.Print,
|
||||
module Juvix.Compiler.Concrete.Print.Base,
|
||||
module Juvix.Data.Effect.ExactPrint,
|
||||
)
|
||||
where
|
||||
|
||||
import Juvix.Compiler.Concrete.Pretty.Options
|
||||
import Juvix.Compiler.Concrete.Print.Base
|
||||
import Juvix.Data.Effect.ExactPrint
|
||||
import Juvix.Data.PPOutput
|
||||
import Juvix.Prelude
|
||||
|
||||
ppOutDefault :: (HasLoc c, PrettyPrint c) => Comments -> c -> AnsiText
|
||||
ppOutDefault cs = AnsiText . PPOutput . doc defaultOptions cs
|
||||
|
||||
ppOut :: (CanonicalProjection a Options, PrettyPrint c, HasLoc c) => a -> Comments -> c -> AnsiText
|
||||
ppOut o cs = AnsiText . PPOutput . doc (project o) cs
|
360
src/Juvix/Compiler/Concrete/Print/Base.hs
Normal file
360
src/Juvix/Compiler/Concrete/Print/Base.hs
Normal file
@ -0,0 +1,360 @@
|
||||
module Juvix.Compiler.Concrete.Print.Base where
|
||||
|
||||
import Data.List.NonEmpty.Extra qualified as NonEmpty
|
||||
import Data.Text qualified as Text
|
||||
import Juvix.Compiler.Concrete.Data.ScopedName qualified as S
|
||||
import Juvix.Compiler.Concrete.Language
|
||||
import Juvix.Compiler.Concrete.Pretty.Base qualified as P
|
||||
import Juvix.Compiler.Concrete.Pretty.Options
|
||||
import Juvix.Data.CodeAnn (Ann, CodeAnn (..), ppStringLit)
|
||||
import Juvix.Data.Effect.ExactPrint
|
||||
import Juvix.Data.Keyword.All
|
||||
import Juvix.Prelude.Base hiding ((<+>), (<+?>), (<?+>), (?<>))
|
||||
import Juvix.Prelude.Path
|
||||
import Juvix.Prelude.Pretty (annotate, pretty)
|
||||
|
||||
class PrettyPrint a where
|
||||
ppCode :: Members '[ExactPrint, Reader Options] r => a -> Sem r ()
|
||||
|
||||
instance PrettyPrint Keyword where
|
||||
ppCode = noLoc . pretty
|
||||
|
||||
instance PrettyPrint KeywordRef where
|
||||
ppCode = ppMorpheme
|
||||
|
||||
doc :: (PrettyPrint c, HasLoc c) => Options -> Comments -> c -> Doc Ann
|
||||
doc opts cs x =
|
||||
run
|
||||
. execExactPrint (fileComments file cs)
|
||||
. runReader opts
|
||||
. ppCode
|
||||
$ x
|
||||
where
|
||||
file :: Path Abs File
|
||||
file = getLoc x ^. intervalFile
|
||||
|
||||
ppModulePathType ::
|
||||
forall t s r.
|
||||
(SingI t, SingI s, Members '[ExactPrint, Reader Options] r) =>
|
||||
ModulePathType s t ->
|
||||
Sem r ()
|
||||
ppModulePathType x = case sing :: SStage s of
|
||||
SParsed -> case sing :: SModuleIsTop t of
|
||||
SModuleLocal -> noLoc (pretty x)
|
||||
SModuleTop -> ppCode x
|
||||
SScoped -> case sing :: SModuleIsTop t of
|
||||
SModuleLocal -> P.ppCode x >>= morpheme (getLoc x) . P.annSDef x
|
||||
SModuleTop -> P.ppCode x >>= morpheme (getLoc x) . P.annSDef x
|
||||
|
||||
instance (SingI t) => PrettyPrint (Module 'Scoped t) where
|
||||
ppCode :: forall r. (Members '[ExactPrint, Reader Options] r) => Module 'Scoped t -> Sem r ()
|
||||
ppCode Module {..} = do
|
||||
let moduleBody' = indent (ppCode _moduleBody)
|
||||
modulePath' = ppModulePathType _modulePath
|
||||
moduleDoc' :: Sem r () = maybe (return ()) ppCode _moduleDoc
|
||||
moduleDoc'
|
||||
<> ppCode _moduleKw
|
||||
<+> modulePath'
|
||||
<> ppCode kwSemicolon
|
||||
<> line
|
||||
<> moduleBody'
|
||||
<> line
|
||||
<> ppCode kwEnd
|
||||
<> lastSemicolon
|
||||
where
|
||||
lastSemicolon :: Sem r ()
|
||||
lastSemicolon = case sing :: SModuleIsTop t of
|
||||
SModuleLocal -> return ()
|
||||
SModuleTop -> semicolon
|
||||
|
||||
instance PrettyPrint [Statement 'Scoped] where
|
||||
ppCode :: forall r. Members '[ExactPrint, Reader Options] r => [Statement 'Scoped] -> Sem r ()
|
||||
ppCode ss = vsep2 (map ppGroup (P.groupStatements ss))
|
||||
where
|
||||
ppGroup :: [Statement 'Scoped] -> Sem r ()
|
||||
ppGroup = vsep . endSemicolon . map ppCode
|
||||
|
||||
instance PrettyPrint TopModulePath where
|
||||
ppCode t@TopModulePath {..} =
|
||||
mapM P.ppSymbol (_modulePathDir ++ [_modulePathName]) >>= morpheme (getLoc t) . P.dotted
|
||||
|
||||
instance (HasLoc n, P.PrettyCode n) => PrettyPrint (S.Name' n) where
|
||||
ppCode = ppMorpheme
|
||||
|
||||
instance PrettyPrint Name where
|
||||
ppCode n = case n of
|
||||
NameUnqualified s -> ppMorpheme s
|
||||
NameQualified s -> ppCode s
|
||||
|
||||
instance PrettyPrint QualifiedName where
|
||||
ppCode :: Members '[ExactPrint, Reader Options] r => QualifiedName -> Sem r ()
|
||||
ppCode q@QualifiedName {..} = do
|
||||
let symbols = _qualifiedPath ^. pathParts NonEmpty.|> _qualifiedSymbol
|
||||
str <- P.dotted <$> mapM P.ppSymbol symbols
|
||||
morpheme (getLoc q) str
|
||||
|
||||
ppMorpheme :: (Members '[ExactPrint, Reader Options] r, P.PrettyCode c, HasLoc c) => c -> Sem r ()
|
||||
ppMorpheme n = P.ppCode n >>= morpheme (getLoc n)
|
||||
|
||||
instance PrettyPrint (ModuleRef'' 'S.Concrete 'ModuleTop) where
|
||||
ppCode m = ppCode (m ^. moduleRefName)
|
||||
|
||||
instance PrettyPrint (Import 'Scoped) where
|
||||
ppCode :: Members '[ExactPrint, Reader Options] r => Import 'Scoped -> Sem r ()
|
||||
ppCode i = do
|
||||
ppCode (i ^. importKw)
|
||||
<+> ppCode (i ^. importModule)
|
||||
|
||||
instance PrettyPrint OperatorSyntaxDef where
|
||||
ppCode OperatorSyntaxDef {..} = do
|
||||
opSymbol' <- P.ppUnkindedSymbol _opSymbol
|
||||
fi
|
||||
<+> morpheme (getLoc _opSymbol) opSymbol'
|
||||
where
|
||||
fi = do
|
||||
p <- P.ppCode (_opFixity ^. fixityPrecedence)
|
||||
ppCode _opKw <+> noLoc p
|
||||
|
||||
instance PrettyPrint Expression where
|
||||
ppCode = ppMorpheme
|
||||
|
||||
instance PrettyPrint (Example 'Scoped) where
|
||||
ppCode e =
|
||||
noLoc P.ppJudocStart
|
||||
<+> noLoc P.ppJudocExampleStart
|
||||
<+> ppCode (e ^. exampleExpression)
|
||||
<> noLoc P.kwSemicolon
|
||||
<> line
|
||||
|
||||
instance PrettyPrint (JudocParagraphLine 'Scoped) where
|
||||
ppCode = ppMorpheme
|
||||
|
||||
instance PrettyPrint (Judoc 'Scoped) where
|
||||
ppCode (Judoc blocks) = mconcatMapM ppCode blocks
|
||||
|
||||
instance PrettyPrint (JudocBlock 'Scoped) where
|
||||
ppCode = \case
|
||||
JudocParagraph l -> vsep (ppCode <$> l)
|
||||
JudocExample e -> ppCode e
|
||||
|
||||
instance PrettyPrint (JudocAtom 'Scoped) where
|
||||
ppCode :: forall r. Members '[ExactPrint, Reader Options] r => JudocAtom 'Scoped -> Sem r ()
|
||||
ppCode = \case
|
||||
JudocExpression e -> semiDelim (ppCode e)
|
||||
JudocText t -> noLoc (annotate AnnComment (pretty t))
|
||||
where
|
||||
semiDelim :: Sem r () -> Sem r ()
|
||||
semiDelim x = semi >> x >> semi
|
||||
where
|
||||
semi :: Sem r ()
|
||||
semi = noLoc (annotate AnnComment (pretty @Text ";"))
|
||||
|
||||
instance PrettyPrint (AxiomDef 'Scoped) where
|
||||
ppCode :: forall r. Members '[ExactPrint, Reader Options] r => AxiomDef 'Scoped -> Sem r ()
|
||||
ppCode AxiomDef {..} = do
|
||||
axiomName' <- P.annDef _axiomName <$> P.ppSymbol _axiomName
|
||||
let builtin' :: Maybe (Sem r ()) = (\x -> P.ppCode x >>= morpheme (getLoc x)) <$> _axiomBuiltin
|
||||
_axiomDoc' :: Maybe (Sem r ()) = ppCode <$> _axiomDoc
|
||||
_axiomDoc'
|
||||
?<> builtin'
|
||||
<?+> ppCode _axiomKw
|
||||
<+> morpheme (getLoc _axiomName) axiomName'
|
||||
<+> noLoc P.kwColon
|
||||
<+> ppCode _axiomType
|
||||
|
||||
instance PrettyPrint (WithLoc BuiltinInductive) where
|
||||
ppCode b = P.ppCode (b ^. withLocParam) >>= morpheme (getLoc b)
|
||||
|
||||
instance PrettyPrint (WithLoc BuiltinFunction) where
|
||||
ppCode b = P.ppCode (b ^. withLocParam) >>= morpheme (getLoc b)
|
||||
|
||||
instance PrettyPrint (TypeSignature 'Scoped) where
|
||||
ppCode :: forall r. Members '[ExactPrint, Reader Options] r => TypeSignature 'Scoped -> Sem r ()
|
||||
ppCode TypeSignature {..} = do
|
||||
let termin' :: Maybe (Sem r ()) = (<> line) . ppCode <$> _sigTerminating
|
||||
doc' :: Maybe (Sem r ()) = ppCode <$> _sigDoc
|
||||
builtin' :: Maybe (Sem r ()) = ppCode <$> _sigBuiltin
|
||||
type' = ppCode _sigType
|
||||
name' = region (P.annDef _sigName) (ppCode _sigName)
|
||||
doc'
|
||||
?<> builtin'
|
||||
<?+> termin'
|
||||
?<> hang
|
||||
( name'
|
||||
<+> noLoc P.kwColon
|
||||
<+> type'
|
||||
)
|
||||
|
||||
instance PrettyPrint Pattern where
|
||||
ppCode = ppMorpheme
|
||||
|
||||
delimIf :: Members '[ExactPrint] r => IsImplicit -> Bool -> Sem r () -> Sem r ()
|
||||
delimIf Implicit _ = braces
|
||||
delimIf Explicit True = parens
|
||||
delimIf Explicit False = id
|
||||
|
||||
instance PrettyPrint PatternArg where
|
||||
ppCode PatternArg {..} = do
|
||||
let name' = ppCode <$> _patternArgName
|
||||
pat' = ppCode _patternArgPattern
|
||||
(name' <&> (<> noLoc P.kwAt))
|
||||
?<> delimIf _patternArgIsImplicit delimCond pat'
|
||||
where
|
||||
delimCond :: Bool
|
||||
delimCond = isJust _patternArgName && not (isAtomic _patternArgPattern)
|
||||
|
||||
instance PrettyPrint (WithLoc Text) where
|
||||
ppCode k = morpheme (getLoc k) (pretty (k ^. withLocParam))
|
||||
|
||||
ppUnkindedSymbol :: Members '[Reader Options, ExactPrint] r => WithLoc Text -> Sem r ()
|
||||
ppUnkindedSymbol = region (annotate AnnUnkindedSym) . ppCode
|
||||
|
||||
ppAtom :: (HasAtomicity c, PrettyPrint c, Members '[ExactPrint, Reader Options] r) => c -> Sem r ()
|
||||
ppAtom c
|
||||
| isAtomic c = ppCode c
|
||||
| otherwise = parens (ppCode c)
|
||||
|
||||
instance PrettyPrint UsingHiding where
|
||||
ppCode uh = do
|
||||
let bracedList =
|
||||
encloseSep
|
||||
(noLoc P.kwBraceL)
|
||||
(noLoc P.kwBraceR)
|
||||
(noLoc P.kwSemicolon)
|
||||
(ppUnkindedSymbol <$> syms)
|
||||
noLoc (pretty word) <+> bracedList
|
||||
where
|
||||
(word, syms) = case uh of
|
||||
Using s -> (kwUsing, s)
|
||||
Hiding s -> (kwHiding, s)
|
||||
|
||||
instance PrettyPrint ModuleRef where
|
||||
ppCode (ModuleRef' (_ :&: ModuleRef'' {..})) = ppCode _moduleRefName
|
||||
|
||||
instance PrettyPrint (OpenModule 'Scoped) where
|
||||
ppCode :: forall r. Members '[ExactPrint, Reader Options] r => OpenModule 'Scoped -> Sem r ()
|
||||
ppCode OpenModule {..} = do
|
||||
let name' = ppCode _openModuleName
|
||||
usingHiding' = ppCode <$> _openUsingHiding
|
||||
openParameters' = hsep . fmap ppAtom <$> nonEmpty _openParameters
|
||||
importkw' = ppCode <$> _openModuleImportKw
|
||||
public' = case _openPublic of
|
||||
Public -> Just (noLoc P.kwPublic)
|
||||
NoPublic -> Nothing
|
||||
ppCode _openModuleKw
|
||||
<+?> importkw'
|
||||
<+> name'
|
||||
<+?> openParameters'
|
||||
<+?> usingHiding'
|
||||
<+?> public'
|
||||
|
||||
instance PrettyPrint (FunctionClause 'Scoped) where
|
||||
ppCode :: forall r. Members '[ExactPrint, Reader Options] r => FunctionClause 'Scoped -> Sem r ()
|
||||
ppCode FunctionClause {..} = do
|
||||
let clauseFun' = ppCode _clauseOwnerFunction
|
||||
clausePatterns' = case nonEmpty _clausePatterns of
|
||||
Nothing -> Nothing
|
||||
Just ne -> Just (hsep (ppPatternAtom <$> ne))
|
||||
clauseBody' = ppCode _clauseBody
|
||||
clauseFun'
|
||||
<+?> clausePatterns'
|
||||
<+> noLoc P.kwAssign
|
||||
<+> nest clauseBody'
|
||||
|
||||
ppPatternAtom :: forall r. (Members '[Reader Options, ExactPrint] r) => PatternArg -> Sem r ()
|
||||
ppPatternAtom pat =
|
||||
case pat ^. patternArgPattern of
|
||||
PatternVariable s | s ^. S.nameVerbatim == "=" -> parens (ppAtom pat)
|
||||
_ -> ppAtom pat
|
||||
|
||||
instance PrettyPrint (InductiveParameter 'Scoped) where
|
||||
ppCode InductiveParameter {..} = do
|
||||
let name' = region (P.annDef _inductiveParameterName) (ppCode _inductiveParameterName)
|
||||
ty' = ppCode _inductiveParameterType
|
||||
parens (name' <+> ppCode kwColon <+> ty')
|
||||
|
||||
instance PrettyPrint (NonEmpty (InductiveParameter 'Scoped)) where
|
||||
ppCode = hsep . fmap ppCode
|
||||
|
||||
instance PrettyPrint (InductiveConstructorDef 'Scoped) where
|
||||
ppCode InductiveConstructorDef {..} = do
|
||||
let constructorName' = region (P.annDef _constructorName) (ppCode _constructorName)
|
||||
constructorType' = ppCode _constructorType
|
||||
doc' = ppCode <$> _constructorDoc
|
||||
doc' ?<> hang (constructorName' <+> noLoc P.kwColon <+> constructorType')
|
||||
|
||||
instance PrettyPrint (InductiveDef 'Scoped) where
|
||||
ppCode :: forall r. Members '[ExactPrint, Reader Options] r => InductiveDef 'Scoped -> Sem r ()
|
||||
ppCode InductiveDef {..} = do
|
||||
let doc' = ppCode <$> _inductiveDoc
|
||||
constrs' = ppConstructorBlock _inductiveConstructors
|
||||
sig' = do
|
||||
let builtin' = ppCode <$> _inductiveBuiltin
|
||||
name' = region (P.annDef _inductiveName) (ppCode _inductiveName)
|
||||
params' = ppCode <$> nonEmpty _inductiveParameters
|
||||
ty' = case _inductiveType of
|
||||
Nothing -> Nothing
|
||||
Just e -> Just (noLoc P.kwColon <+> ppCode e)
|
||||
builtin'
|
||||
<?+> ppCode _inductiveKw
|
||||
<+> name'
|
||||
<+?> params'
|
||||
<+?> ty'
|
||||
doc'
|
||||
?<> sig'
|
||||
<+> noLoc P.kwAssign
|
||||
<> line
|
||||
<> (indent . align) constrs'
|
||||
where
|
||||
ppConstructorBlock :: NonEmpty (InductiveConstructorDef 'Scoped) -> Sem r ()
|
||||
ppConstructorBlock cs =
|
||||
vsep (map ((noLoc P.kwPipe <+>) . ppCode) (toList cs))
|
||||
|
||||
instance PrettyPrint (WithLoc Backend) where
|
||||
ppCode = ppMorpheme
|
||||
|
||||
instance PrettyPrint ForeignBlock where
|
||||
ppCode ForeignBlock {..} = do
|
||||
let _foreignBackend' = ppCode _foreignBackend
|
||||
ppCode _foreignKw
|
||||
<+> _foreignBackend'
|
||||
<+> lbrace
|
||||
<> line
|
||||
<> noLoc (pretty (escape _foreignCode))
|
||||
<> line
|
||||
<> rbrace
|
||||
where
|
||||
escape :: Text -> Text
|
||||
escape = Text.replace "}" "\\}"
|
||||
|
||||
instance PrettyPrint BackendItem where
|
||||
ppCode BackendItem {..} = do
|
||||
let backend' = ppCode _backendItemBackend
|
||||
backend'
|
||||
<+> noLoc P.kwMapsto
|
||||
<+> noLoc (ppStringLit _backendItemCode)
|
||||
|
||||
instance PrettyPrint (Compile 'Scoped) where
|
||||
ppCode :: forall r. Members '[ExactPrint, Reader Options] r => Compile 'Scoped -> Sem r ()
|
||||
ppCode Compile {..} = do
|
||||
let name' = ppCode _compileName
|
||||
items' = ppBlock _compileBackendItems
|
||||
ppCode _compileKw
|
||||
<+> name'
|
||||
<+> items'
|
||||
where
|
||||
ppBlock :: PrettyPrint c => [c] -> Sem r ()
|
||||
ppBlock = bracesIndent . vsep . map ((<> semicolon) . ppCode)
|
||||
|
||||
instance PrettyPrint (Statement 'Scoped) where
|
||||
ppCode = \case
|
||||
StatementOperator o -> ppCode o
|
||||
StatementTypeSignature s -> ppCode s
|
||||
StatementImport i -> ppCode i
|
||||
StatementInductive i -> ppCode i
|
||||
StatementModule m -> ppCode m
|
||||
StatementOpenModule o -> ppCode o
|
||||
StatementFunctionClause c -> ppCode c
|
||||
StatementAxiom a -> ppCode a
|
||||
StatementForeign f -> ppCode f
|
||||
StatementCompile c -> ppCode c
|
@ -220,18 +220,20 @@ checkImport ::
|
||||
(Members '[Error ScoperError, State Scope, Reader ScopeParameters, Files, State ScoperState, InfoTableBuilder, Parser.InfoTableBuilder, NameIdGen, PathResolver] r) =>
|
||||
Import 'Parsed ->
|
||||
Sem r (Import 'Scoped)
|
||||
checkImport import_@(Import path) = do
|
||||
checkImport import_@(Import kw path) = do
|
||||
checkCycle
|
||||
cache <- gets (^. scoperModulesCache . cachedModules)
|
||||
moduleRef <- maybe (readScopeModule import_) return (cache ^. at path)
|
||||
let checked = moduleRef ^. moduleRefModule
|
||||
sname = checked ^. modulePath
|
||||
sname :: S.TopModulePath = checked ^. modulePath
|
||||
sname' :: S.Name = set S.nameConcrete (topModulePathToName path) sname
|
||||
moduleId = sname ^. S.nameId
|
||||
cmoduleRef :: ModuleRef'' 'S.Concrete 'ModuleTop = set moduleRefName sname' moduleRef
|
||||
modify (over scopeTopModules (HashMap.insert path moduleRef))
|
||||
registerName (set S.nameConcrete path sname)
|
||||
let moduleRef' = mkModuleRef' moduleRef
|
||||
modify (over scoperModules (HashMap.insert moduleId moduleRef'))
|
||||
return (Import checked)
|
||||
return (Import kw cmoduleRef)
|
||||
where
|
||||
checkCycle :: Sem r ()
|
||||
checkCycle = do
|
||||
@ -501,7 +503,8 @@ checkInductiveDef ty@InductiveDef {..} = do
|
||||
_inductiveParameters = inductiveParameters',
|
||||
_inductiveType = inductiveType',
|
||||
_inductiveConstructors = inductiveConstructors',
|
||||
_inductivePositive = ty ^. inductivePositive
|
||||
_inductivePositive = ty ^. inductivePositive,
|
||||
_inductiveKw
|
||||
}
|
||||
|
||||
createExportsTable :: ExportInfo -> HashSet NameId
|
||||
@ -512,7 +515,7 @@ createExportsTable ei = foldr (HashSet.insert . getNameId) HashSet.empty (HashMa
|
||||
EntryInductive r -> getNameRefId (r ^. inductiveRefName)
|
||||
EntryFunction r -> getNameRefId (r ^. functionRefName)
|
||||
EntryConstructor r -> getNameRefId (r ^. constructorRefName)
|
||||
EntryModule r -> getNameRefId (getModuleRefNameType r)
|
||||
EntryModule r -> getModuleRefNameId r
|
||||
|
||||
checkTopModules ::
|
||||
forall r.
|
||||
@ -536,7 +539,7 @@ checkTopModule ::
|
||||
(Members '[Error ScoperError, Reader ScopeParameters, Files, State ScoperState, InfoTableBuilder, Parser.InfoTableBuilder, NameIdGen, PathResolver] r) =>
|
||||
Module 'Parsed 'ModuleTop ->
|
||||
Sem r (ModuleRef'' 'S.NotConcrete 'ModuleTop)
|
||||
checkTopModule m@(Module path params doc body) = do
|
||||
checkTopModule m@(Module _moduleKw path params doc body) = do
|
||||
checkPath
|
||||
r <- checkedModule
|
||||
modify (over (scoperModulesCache . cachedModules) (HashMap.insert path r))
|
||||
@ -545,7 +548,7 @@ checkTopModule m@(Module path params doc body) = do
|
||||
checkPath :: (Members '[Error ScoperError, PathResolver] s) => Sem s ()
|
||||
checkPath = do
|
||||
expectedPath <- expectedModulePath path
|
||||
let actualPath = absFile (getLoc path ^. intervalFile)
|
||||
let actualPath = getLoc path ^. intervalFile
|
||||
unlessM (equalPaths expectedPath actualPath) $
|
||||
throw
|
||||
( ErrWrongTopModuleName
|
||||
@ -588,7 +591,8 @@ checkTopModule m@(Module path params doc body) = do
|
||||
{ _modulePath = path',
|
||||
_moduleParameters = params',
|
||||
_moduleBody = body',
|
||||
_moduleDoc = doc'
|
||||
_moduleDoc = doc',
|
||||
_moduleKw
|
||||
}
|
||||
_moduleRefName = set S.nameConcrete () path'
|
||||
return (ModuleRef'' {..}, path')
|
||||
@ -635,7 +639,8 @@ checkLocalModule Module {..} = do
|
||||
{ _modulePath = _modulePath',
|
||||
_moduleParameters = moduleParameters',
|
||||
_moduleBody = moduleBody',
|
||||
_moduleDoc = moduleDoc'
|
||||
_moduleDoc = moduleDoc',
|
||||
_moduleKw
|
||||
}
|
||||
entry :: ModuleRef' 'S.NotConcrete
|
||||
entry = mkModuleRef' @'ModuleLocal ModuleRef'' {..}
|
||||
@ -716,17 +721,17 @@ checkOpenImportModule ::
|
||||
OpenModule 'Parsed ->
|
||||
Sem r (OpenModule 'Scoped)
|
||||
checkOpenImportModule op
|
||||
| op ^. openModuleImport =
|
||||
| Just k <- op ^. openModuleImportKw =
|
||||
let moduleNameToTopModulePath :: Name -> TopModulePath
|
||||
moduleNameToTopModulePath = \case
|
||||
NameUnqualified s -> TopModulePath [] s
|
||||
NameQualified (QualifiedName (SymbolPath p) s) -> TopModulePath (toList p) s
|
||||
import_ :: Import 'Parsed
|
||||
import_ = Import (moduleNameToTopModulePath (op ^. openModuleName))
|
||||
import_ = Import k (moduleNameToTopModulePath (op ^. openModuleName))
|
||||
in do
|
||||
void (checkImport import_)
|
||||
scopedOpen <- checkOpenModule (set openModuleImport False op)
|
||||
return (set openModuleImport True scopedOpen)
|
||||
scopedOpen <- checkOpenModule (set openModuleImportKw Nothing op)
|
||||
return (set openModuleImportKw (Just k) scopedOpen)
|
||||
| otherwise = impossible
|
||||
|
||||
checkOpenModuleNoImport ::
|
||||
@ -735,7 +740,7 @@ checkOpenModuleNoImport ::
|
||||
OpenModule 'Parsed ->
|
||||
Sem r (OpenModule 'Scoped)
|
||||
checkOpenModuleNoImport OpenModule {..}
|
||||
| _openModuleImport = error "unsupported: open import statement"
|
||||
| isJust _openModuleImportKw = error "unsupported: open import statement"
|
||||
| otherwise = do
|
||||
openModuleName'@(ModuleRef' (_ :&: moduleRef'')) <- lookupModuleSymbol _openModuleName
|
||||
openParameters' <- mapM checkParseExpressionAtoms _openParameters
|
||||
@ -793,7 +798,7 @@ checkOpenModule ::
|
||||
OpenModule 'Parsed ->
|
||||
Sem r (OpenModule 'Scoped)
|
||||
checkOpenModule op
|
||||
| op ^. openModuleImport = checkOpenImportModule op
|
||||
| isJust (op ^. openModuleImportKw) = checkOpenImportModule op
|
||||
| otherwise = checkOpenModuleNoImport op
|
||||
|
||||
checkFunctionClause ::
|
||||
@ -897,7 +902,7 @@ checkBackendItems ::
|
||||
Sem r (HashSet Backend)
|
||||
checkBackendItems _ [] bset = return bset
|
||||
checkBackendItems sym (b : bs) bset =
|
||||
let cBackend = b ^. backendItemBackend
|
||||
let cBackend = b ^. backendItemBackend . withLocParam
|
||||
in if
|
||||
| HashSet.member cBackend bset ->
|
||||
throw
|
||||
@ -1011,14 +1016,15 @@ checkLetBlock LetBlock {..} = do
|
||||
return
|
||||
LetBlock
|
||||
{ _letClauses = letClauses',
|
||||
_letExpression = letExpression'
|
||||
_letExpression = letExpression',
|
||||
_letKw
|
||||
}
|
||||
|
||||
checkLambda ::
|
||||
(Members '[Error ScoperError, State Scope, State ScoperState, Reader LocalVars, InfoTableBuilder, NameIdGen] r) =>
|
||||
Lambda 'Parsed ->
|
||||
Sem r (Lambda 'Scoped)
|
||||
checkLambda Lambda {..} = Lambda <$> mapM checkLambdaClause _lambdaClauses
|
||||
checkLambda Lambda {..} = Lambda _lambdaKw <$> mapM checkLambdaClause _lambdaClauses
|
||||
|
||||
checkLambdaClause ::
|
||||
(Members '[Error ScoperError, State Scope, State ScoperState, Reader LocalVars, InfoTableBuilder, NameIdGen] r) =>
|
||||
@ -1250,7 +1256,7 @@ checkJudocLine ::
|
||||
(Members '[Error ScoperError, State Scope, State ScoperState, Reader LocalVars, InfoTableBuilder, NameIdGen] r) =>
|
||||
JudocParagraphLine 'Parsed ->
|
||||
Sem r (JudocParagraphLine 'Scoped)
|
||||
checkJudocLine (JudocParagraphLine atoms) = JudocParagraphLine <$> mapM checkJudocAtom atoms
|
||||
checkJudocLine (JudocParagraphLine atoms) = JudocParagraphLine <$> mapM (mapM checkJudocAtom) atoms
|
||||
|
||||
checkJudocAtom ::
|
||||
(Members '[Error ScoperError, State Scope, State ScoperState, Reader LocalVars, InfoTableBuilder, NameIdGen] r) =>
|
||||
|
@ -5,6 +5,7 @@ import Juvix.Compiler.Concrete.Data.ParsedInfoTable qualified as Parsed
|
||||
import Juvix.Compiler.Concrete.Data.Scope
|
||||
import Juvix.Compiler.Concrete.Language
|
||||
import Juvix.Compiler.Concrete.Translation.FromSource.Data.Context qualified as Parsed
|
||||
import Juvix.Data.Comment
|
||||
import Juvix.Prelude
|
||||
|
||||
data ScoperResult = ScoperResult
|
||||
@ -20,3 +21,6 @@ makeLenses ''ScoperResult
|
||||
|
||||
mainModule :: Lens' ScoperResult (Module 'Scoped 'ModuleTop)
|
||||
mainModule = resultModules . _head1
|
||||
|
||||
comments :: Lens' ScoperResult Comments
|
||||
comments = resultParserResult . Parsed.resultTable . Parsed.infoParsedComments
|
||||
|
@ -50,11 +50,9 @@ fromSource e = mapError (JuvixError @ParserError) $ do
|
||||
return txt
|
||||
| otherwise = readFile' fp
|
||||
|
||||
-- | The fileName is only used for reporting errors. It is safe to pass
|
||||
-- an empty string.
|
||||
expressionFromTextSource ::
|
||||
(Members '[Error JuvixError, NameIdGen] r) =>
|
||||
FilePath ->
|
||||
Members '[Error JuvixError, NameIdGen] r =>
|
||||
Path Abs File ->
|
||||
Text ->
|
||||
Sem r (ExpressionAtoms 'Parsed)
|
||||
expressionFromTextSource fp txt = mapError (JuvixError @ParserError) $ do
|
||||
@ -63,9 +61,7 @@ expressionFromTextSource fp txt = mapError (JuvixError @ParserError) $ do
|
||||
Left e -> throw e
|
||||
Right exp' -> return exp'
|
||||
|
||||
-- | The fileName is only used for reporting errors. It is safe to pass
|
||||
-- an empty string.
|
||||
runModuleParser :: (Members '[NameIdGen] r) => Path Abs File -> Text -> Sem r (Either ParserError (InfoTable, Module 'Parsed 'ModuleTop))
|
||||
runModuleParser :: Members '[NameIdGen] r => Path Abs File -> Text -> Sem r (Either ParserError (InfoTable, Module 'Parsed 'ModuleTop))
|
||||
runModuleParser fileName input = do
|
||||
m <-
|
||||
runInfoTableBuilder $
|
||||
@ -75,18 +71,16 @@ runModuleParser fileName input = do
|
||||
(_, Left err) -> return (Left (ParserError err))
|
||||
(tbl, Right r) -> return (Right (tbl, r))
|
||||
|
||||
-- | The fileName is only used for reporting errors. It is safe to pass
|
||||
-- an empty string.
|
||||
runExpressionParser ::
|
||||
(Members '[NameIdGen] r) =>
|
||||
FilePath ->
|
||||
Members '[NameIdGen] r =>
|
||||
Path Abs File ->
|
||||
Text ->
|
||||
Sem r (Either ParserError (ExpressionAtoms 'Parsed))
|
||||
runExpressionParser fileName input = do
|
||||
m <-
|
||||
runInfoTableBuilder $
|
||||
evalState (Nothing @(Judoc 'Parsed)) $
|
||||
P.runParserT parseExpressionAtoms fileName input
|
||||
P.runParserT parseExpressionAtoms (toFilePath fileName) input
|
||||
case m of
|
||||
(_, Left err) -> return (Left (ParserError err))
|
||||
(_, Right r) -> return (Right r)
|
||||
@ -159,88 +153,90 @@ stashJudoc = do
|
||||
judocBlocks :: ParsecS r (Judoc 'Parsed)
|
||||
judocBlocks = Judoc <$> some judocBlock
|
||||
judocBlock :: ParsecS r (JudocBlock 'Parsed)
|
||||
judocBlock = comment $ do
|
||||
judocBlock = do
|
||||
p <-
|
||||
judocExample
|
||||
<|> judocParagraph
|
||||
|
||||
void (many judocEmptyLine)
|
||||
return p
|
||||
|
||||
judocParagraph :: ParsecS r (JudocBlock 'Parsed)
|
||||
judocParagraph = JudocParagraph <$> some1 judocLine
|
||||
|
||||
judocExample :: ParsecS r (JudocBlock 'Parsed)
|
||||
judocExample = do
|
||||
-- TODO judocText?
|
||||
P.try (judocStart >> judocExampleStart)
|
||||
uid <- P.lift freshNameId
|
||||
e <- parseExpressionAtoms
|
||||
_exampleId <- P.lift freshNameId
|
||||
(_exampleExpression, _exampleLoc) <- interval parseExpressionAtoms
|
||||
kw kwSemicolon
|
||||
space
|
||||
return (JudocExample (Example uid e))
|
||||
return (JudocExample (Example {..}))
|
||||
|
||||
judocLine :: ParsecS r (JudocParagraphLine 'Parsed)
|
||||
judocLine = lexeme $ do
|
||||
P.try (judocStart >> P.notFollowedBy (P.choice [judocExampleStart, void P.newline]))
|
||||
ln <- JudocParagraphLine <$> some1 judocAtom
|
||||
ln <- JudocParagraphLine <$> some1 (withLoc judocAtom)
|
||||
P.newline
|
||||
return ln
|
||||
|
||||
judocAtom :: forall r. (Members '[InfoTableBuilder, JudocStash, NameIdGen] r) => ParsecS r (JudocAtom 'Parsed)
|
||||
judocAtom =
|
||||
JudocText <$> judocText
|
||||
JudocText <$> judocAtomText
|
||||
<|> JudocExpression <$> judocExpression
|
||||
where
|
||||
judocText :: ParsecS r Text
|
||||
judocText = comment (takeWhile1P Nothing isValidText)
|
||||
judocAtomText :: ParsecS r Text
|
||||
judocAtomText = judocText (takeWhile1P Nothing isValidText)
|
||||
where
|
||||
isValidText :: Char -> Bool
|
||||
isValidText = (`notElem` ['\n', ';'])
|
||||
judocExpression :: ParsecS r (ExpressionAtoms 'Parsed)
|
||||
judocExpression = do
|
||||
comment_ (P.char ';')
|
||||
judocText_ (P.char ';')
|
||||
e <- parseExpressionAtoms
|
||||
comment_ (P.char ';')
|
||||
judocText_ (P.char ';')
|
||||
return e
|
||||
|
||||
builtinInductive :: (Members '[InfoTableBuilder, JudocStash, NameIdGen] r) => ParsecS r BuiltinInductive
|
||||
builtinInductive :: Members '[InfoTableBuilder, JudocStash, NameIdGen] r => ParsecS r (WithLoc BuiltinInductive)
|
||||
builtinInductive = builtinHelper
|
||||
|
||||
builtinFunction :: (Members '[InfoTableBuilder, JudocStash, NameIdGen] r) => ParsecS r BuiltinFunction
|
||||
builtinFunction :: Members '[InfoTableBuilder, JudocStash, NameIdGen] r => ParsecS r (WithLoc BuiltinFunction)
|
||||
builtinFunction = builtinHelper
|
||||
|
||||
builtinAxiom :: (Members '[InfoTableBuilder, JudocStash, NameIdGen] r) => ParsecS r BuiltinAxiom
|
||||
builtinAxiom :: Members '[InfoTableBuilder, JudocStash, NameIdGen] r => ParsecS r (WithLoc BuiltinAxiom)
|
||||
builtinAxiom = builtinHelper
|
||||
|
||||
builtinHelper ::
|
||||
(Members '[InfoTableBuilder, JudocStash, NameIdGen] r, Bounded a, Enum a, Pretty a) =>
|
||||
ParsecS r a
|
||||
ParsecS r (WithLoc a)
|
||||
builtinHelper =
|
||||
P.choice
|
||||
[ kw (asciiKw (prettyText a)) $> a
|
||||
[ (`WithLoc` a) <$> onlyInterval (kw (asciiKw (prettyText a)))
|
||||
| a <- allElements
|
||||
]
|
||||
|
||||
builtinInductiveDef :: (Members '[InfoTableBuilder, JudocStash, NameIdGen] r) => BuiltinInductive -> ParsecS r (InductiveDef 'Parsed)
|
||||
builtinInductiveDef :: Members '[InfoTableBuilder, JudocStash, NameIdGen] r => WithLoc BuiltinInductive -> ParsecS r (InductiveDef 'Parsed)
|
||||
builtinInductiveDef = inductiveDef . Just
|
||||
|
||||
builtinAxiomDef ::
|
||||
(Members '[InfoTableBuilder, JudocStash, NameIdGen] r) =>
|
||||
BuiltinAxiom ->
|
||||
Members '[InfoTableBuilder, JudocStash, NameIdGen] r =>
|
||||
WithLoc BuiltinAxiom ->
|
||||
ParsecS r (AxiomDef 'Parsed)
|
||||
builtinAxiomDef = axiomDef . Just
|
||||
|
||||
builtinTypeSig ::
|
||||
(Members '[InfoTableBuilder, JudocStash, NameIdGen] r) =>
|
||||
BuiltinFunction ->
|
||||
Members '[InfoTableBuilder, JudocStash, NameIdGen] r =>
|
||||
WithLoc BuiltinFunction ->
|
||||
ParsecS r (TypeSignature 'Parsed)
|
||||
builtinTypeSig b = do
|
||||
terminating <- isJust <$> optional (kw kwTerminating)
|
||||
terminating <- optional (kw kwTerminating)
|
||||
fun <- symbol
|
||||
typeSignature terminating fun (Just b)
|
||||
|
||||
builtinStatement :: (Members '[InfoTableBuilder, JudocStash, NameIdGen] r) => ParsecS r (Statement 'Parsed)
|
||||
builtinStatement = do
|
||||
kw kwBuiltin
|
||||
void (kw kwBuiltin)
|
||||
(builtinInductive >>= fmap StatementInductive . builtinInductiveDef)
|
||||
<|> (builtinFunction >>= fmap StatementTypeSignature . builtinTypeSig)
|
||||
<|> (builtinAxiom >>= fmap StatementAxiom . builtinAxiomDef)
|
||||
@ -251,7 +247,7 @@ builtinStatement = do
|
||||
|
||||
compileBlock :: forall r. (Members '[InfoTableBuilder, JudocStash, NameIdGen] r) => ParsecS r (Compile 'Parsed)
|
||||
compileBlock = do
|
||||
kw kwCompile
|
||||
_compileKw <- kw kwCompile
|
||||
_compileName <- symbol
|
||||
_compileBackendItems <- backends
|
||||
return Compile {..}
|
||||
@ -268,12 +264,15 @@ compileBlock = do
|
||||
-- Foreign
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
backend :: (Members '[InfoTableBuilder, JudocStash, NameIdGen] r) => ParsecS r Backend
|
||||
backend = kw ghc $> BackendGhc <|> kw cBackend $> BackendC
|
||||
backend :: Members '[InfoTableBuilder, JudocStash, NameIdGen] r => ParsecS r (WithLoc Backend)
|
||||
backend =
|
||||
withLoc $
|
||||
kw ghc $> BackendGhc
|
||||
<|> kw cBackend $> BackendC
|
||||
|
||||
foreignBlock :: (Members '[InfoTableBuilder, JudocStash, NameIdGen] r) => ParsecS r ForeignBlock
|
||||
foreignBlock = do
|
||||
kw kwForeign
|
||||
_foreignKw <- kw kwForeign
|
||||
_foreignBackend <- backend
|
||||
_foreignCode <- bracedString
|
||||
return ForeignBlock {..}
|
||||
@ -287,18 +286,18 @@ precedence = PrecNat <$> (fst <$> decimal)
|
||||
|
||||
operatorSyntaxDef :: forall r. (Members '[InfoTableBuilder, JudocStash, NameIdGen] r) => ParsecS r OperatorSyntaxDef
|
||||
operatorSyntaxDef = do
|
||||
_fixityArity <- arity
|
||||
(_fixityArity, _opKw) <- arity
|
||||
_fixityPrecedence <- precedence
|
||||
_opSymbol <- symbol
|
||||
let _opFixity = Fixity {..}
|
||||
return OperatorSyntaxDef {..}
|
||||
where
|
||||
arity :: ParsecS r OperatorArity
|
||||
arity :: ParsecS r (OperatorArity, KeywordRef)
|
||||
arity =
|
||||
Binary AssocRight <$ kw kwInfixr
|
||||
<|> Binary AssocLeft <$ kw kwInfixl
|
||||
<|> Binary AssocNone <$ kw kwInfix
|
||||
<|> Unary AssocPostfix <$ kw kwPostfix
|
||||
(Binary AssocRight,) <$> kw kwInfixr
|
||||
<|> (Binary AssocLeft,) <$> kw kwInfixl
|
||||
<|> (Binary AssocNone,) <$> kw kwInfix
|
||||
<|> (Unary AssocPostfix,) <$> kw kwPostfix
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Import statement
|
||||
@ -306,7 +305,7 @@ operatorSyntaxDef = do
|
||||
|
||||
import_ :: (Members '[InfoTableBuilder, JudocStash, NameIdGen] r) => ParsecS r (Import 'Parsed)
|
||||
import_ = do
|
||||
kw kwImport
|
||||
_importKw <- kw kwImport
|
||||
_importModule <- topModulePath
|
||||
return Import {..}
|
||||
|
||||
@ -368,7 +367,7 @@ letClause = either LetTypeSig LetFunClause <$> auxTypeSigFunClause
|
||||
|
||||
letBlock :: (Members '[InfoTableBuilder, JudocStash, NameIdGen] r) => ParsecS r (LetBlock 'Parsed)
|
||||
letBlock = do
|
||||
kw kwLet
|
||||
_letKw <- kw kwLet
|
||||
_letClauses <- braces (P.sepEndBy1 letClause (kw kwSemicolon))
|
||||
kw kwIn
|
||||
_letExpression <- parseExpressionAtoms
|
||||
@ -395,10 +394,10 @@ getJudoc = P.lift $ do
|
||||
return j
|
||||
|
||||
typeSignature ::
|
||||
(Members '[InfoTableBuilder, JudocStash, NameIdGen] r) =>
|
||||
Bool ->
|
||||
Members '[InfoTableBuilder, JudocStash, NameIdGen] r =>
|
||||
Maybe KeywordRef ->
|
||||
Symbol ->
|
||||
Maybe BuiltinFunction ->
|
||||
Maybe (WithLoc BuiltinFunction) ->
|
||||
ParsecS r (TypeSignature 'Parsed)
|
||||
typeSignature _sigTerminating _sigName _sigBuiltin = do
|
||||
kw kwColon
|
||||
@ -411,17 +410,17 @@ auxTypeSigFunClause ::
|
||||
(Members '[InfoTableBuilder, JudocStash, NameIdGen] r) =>
|
||||
ParsecS r (Either (TypeSignature 'Parsed) (FunctionClause 'Parsed))
|
||||
auxTypeSigFunClause = do
|
||||
terminating <- isJust <$> optional (kw kwTerminating)
|
||||
terminating <- optional (kw kwTerminating)
|
||||
sym <- symbol
|
||||
(Left <$> typeSignature terminating sym Nothing)
|
||||
<|> (Right <$> functionClause sym)
|
||||
|
||||
axiomDef ::
|
||||
(Members '[InfoTableBuilder, JudocStash, NameIdGen] r) =>
|
||||
Maybe BuiltinAxiom ->
|
||||
Members '[InfoTableBuilder, JudocStash, NameIdGen] r =>
|
||||
Maybe (WithLoc BuiltinAxiom) ->
|
||||
ParsecS r (AxiomDef 'Parsed)
|
||||
axiomDef _axiomBuiltin = do
|
||||
kw kwAxiom
|
||||
_axiomKw <- kw kwAxiom
|
||||
_axiomDoc <- getJudoc
|
||||
_axiomName <- symbol
|
||||
kw kwColon
|
||||
@ -484,7 +483,7 @@ lambdaClause = do
|
||||
|
||||
lambda :: (Members '[InfoTableBuilder, JudocStash, NameIdGen] r) => ParsecS r (Lambda 'Parsed)
|
||||
lambda = do
|
||||
kw kwLambda
|
||||
_lambdaKw <- kw kwLambda
|
||||
_lambdaClauses <- braces (P.sepEndBy lambdaClause (kw kwSemicolon))
|
||||
return Lambda {..}
|
||||
|
||||
@ -492,10 +491,10 @@ lambda = do
|
||||
-- Data type construction declaration
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
inductiveDef :: (Members '[InfoTableBuilder, JudocStash, NameIdGen] r) => Maybe BuiltinInductive -> ParsecS r (InductiveDef 'Parsed)
|
||||
inductiveDef :: Members '[InfoTableBuilder, JudocStash, NameIdGen] r => Maybe (WithLoc BuiltinInductive) -> ParsecS r (InductiveDef 'Parsed)
|
||||
inductiveDef _inductiveBuiltin = do
|
||||
_inductivePositive <- isJust <$> optional (kw kwPositive)
|
||||
kw kwInductive
|
||||
_inductiveKw <- kw kwInductive
|
||||
_inductiveDoc <- getJudoc
|
||||
_inductiveName <- symbol P.<?> "<type name>"
|
||||
_inductiveParameters <-
|
||||
@ -595,7 +594,7 @@ pmodulePath = case sing :: SModuleIsTop t of
|
||||
|
||||
moduleDef :: (SingI t, Members '[InfoTableBuilder, JudocStash, NameIdGen] r) => ParsecS r (Module 'Parsed t)
|
||||
moduleDef = P.label "<module definition>" $ do
|
||||
kw kwModule
|
||||
_moduleKw <- kw kwModule
|
||||
_moduleDoc <- getJudoc
|
||||
_modulePath <- pmodulePath
|
||||
_moduleParameters <- many inductiveParam
|
||||
@ -615,8 +614,8 @@ atomicExpression = do
|
||||
|
||||
openModule :: forall r. (Members '[InfoTableBuilder, JudocStash, NameIdGen] r) => ParsecS r (OpenModule 'Parsed)
|
||||
openModule = do
|
||||
kw kwOpen
|
||||
_openModuleImport <- isJust <$> optional (kw kwImport)
|
||||
_openModuleKw <- kw kwOpen
|
||||
_openModuleImportKw <- optional (kw kwImport)
|
||||
_openModuleName <- name
|
||||
_openParameters <- many atomicExpression
|
||||
_openUsingHiding <- optional usingOrHiding
|
||||
|
@ -20,17 +20,17 @@ import Text.Megaparsec.Char.Lexer qualified as L
|
||||
|
||||
type OperatorSym = Text
|
||||
|
||||
comment :: (Members '[InfoTableBuilder] r) => ParsecS r a -> ParsecS r a
|
||||
comment c = do
|
||||
judocText :: Members '[InfoTableBuilder] r => ParsecS r a -> ParsecS r a
|
||||
judocText c = do
|
||||
(a, i) <- interval c
|
||||
P.lift (registerComment i)
|
||||
P.lift (registerJudocText i)
|
||||
return a
|
||||
|
||||
comment_ :: (Members '[InfoTableBuilder] r) => ParsecS r a -> ParsecS r ()
|
||||
comment_ = void . comment
|
||||
judocText_ :: Members '[InfoTableBuilder] r => ParsecS r a -> ParsecS r ()
|
||||
judocText_ = void . judocText
|
||||
|
||||
space :: forall r. (Members '[InfoTableBuilder] r) => ParsecS r ()
|
||||
space = space' True comment_
|
||||
space :: forall r. Members '[InfoTableBuilder] r => ParsecS r ()
|
||||
space = space' True >>= mapM_ (P.lift . registerComment)
|
||||
|
||||
lexeme :: (Members '[InfoTableBuilder] r) => ParsecS r a -> ParsecS r a
|
||||
lexeme = L.lexeme space
|
||||
@ -80,9 +80,12 @@ judocStart = P.chunk Str.judocStart >> hspace
|
||||
judocEmptyLine :: (Members '[InfoTableBuilder] r) => ParsecS r ()
|
||||
judocEmptyLine = lexeme (void (P.try (judocStart >> P.newline)))
|
||||
|
||||
kw :: (Member InfoTableBuilder r) => Keyword -> ParsecS r ()
|
||||
kw :: Member InfoTableBuilder r => Keyword -> ParsecS r KeywordRef
|
||||
kw k = lexeme $ kw' k >>= P.lift . registerKeyword
|
||||
|
||||
-- kwOld :: Member InfoTableBuilder r => Keyword -> ParsecS r ()
|
||||
-- kwOld k = lexeme $ kw' k >>= P.lift . registerKeyword
|
||||
|
||||
-- | Same as @identifier@ but does not consume space after it.
|
||||
bareIdentifier :: ParsecS r (Text, Interval)
|
||||
bareIdentifier = interval (rawIdentifier allKeywordStrings)
|
||||
|
@ -13,7 +13,7 @@ import Text.Megaparsec as P hiding (sepBy1, sepEndBy1, some)
|
||||
import Text.Megaparsec.Char.Lexer qualified as L
|
||||
|
||||
space :: ParsecS r ()
|
||||
space = space' False void
|
||||
space = void (space' False)
|
||||
|
||||
lexeme :: ParsecS r a -> ParsecS r a
|
||||
lexeme = L.lexeme space
|
||||
|
@ -93,6 +93,9 @@ instance PrettyCode Lambda where
|
||||
lambdaClauses' <- ppBlock _lambdaClauses
|
||||
return $ kwLambda <+> lambdaClauses'
|
||||
|
||||
instance PrettyCode a => PrettyCode (WithLoc a) where
|
||||
ppCode = ppCode . (^. withLocParam)
|
||||
|
||||
instance PrettyCode BackendItem where
|
||||
ppCode BackendItem {..} = do
|
||||
backend <- ppCode _backendItemBackend
|
||||
|
@ -32,8 +32,8 @@ import Juvix.Prelude
|
||||
type PipelineEff = '[PathResolver, Reader EntryPoint, Files, NameIdGen, Builtins, Error JuvixError, Embed IO]
|
||||
|
||||
arityCheckExpression ::
|
||||
(Members '[Error JuvixError, NameIdGen, Builtins] r) =>
|
||||
FilePath ->
|
||||
Members '[Error JuvixError, NameIdGen, Builtins] r =>
|
||||
Path Abs File ->
|
||||
ExpressionContext ->
|
||||
Text ->
|
||||
Sem r Internal.Expression
|
||||
@ -45,8 +45,8 @@ arityCheckExpression fp ctx txt =
|
||||
>>= Internal.arityCheckExpression (ctx ^. contextInternalResult)
|
||||
|
||||
inferExpression ::
|
||||
(Members '[Error JuvixError, NameIdGen, Builtins] r) =>
|
||||
FilePath ->
|
||||
Members '[Error JuvixError, NameIdGen, Builtins] r =>
|
||||
Path Abs File ->
|
||||
ExpressionContext ->
|
||||
Text ->
|
||||
Sem r Internal.Expression
|
||||
@ -55,8 +55,8 @@ inferExpression fp ctx txt =
|
||||
>>= Internal.inferExpressionType (ctx ^. contextInternalTypedResult)
|
||||
|
||||
compileExpression ::
|
||||
(Members '[Error JuvixError, NameIdGen, Builtins] r) =>
|
||||
FilePath ->
|
||||
Members '[Error JuvixError, NameIdGen, Builtins] r =>
|
||||
Path Abs File ->
|
||||
ExpressionContext ->
|
||||
Text ->
|
||||
Sem r Core.Node
|
||||
@ -66,7 +66,7 @@ compileExpression fp ctx txt =
|
||||
>>= Core.fromInternalExpression (ctx ^. contextCoreResult)
|
||||
|
||||
compileExpressionIO ::
|
||||
FilePath ->
|
||||
Path Abs File ->
|
||||
ExpressionContext ->
|
||||
BuiltinsState ->
|
||||
Text ->
|
||||
@ -79,7 +79,7 @@ compileExpressionIO fp ctx builtinsState txt =
|
||||
$ compileExpression fp ctx txt
|
||||
|
||||
inferExpressionIO ::
|
||||
FilePath ->
|
||||
Path Abs File ->
|
||||
ExpressionContext ->
|
||||
BuiltinsState ->
|
||||
Text ->
|
||||
@ -184,7 +184,6 @@ runIOEither builtinsState entry =
|
||||
. fmap makeArtifacts
|
||||
. runBuiltins builtinsState
|
||||
. runNameIdGen
|
||||
. mapError (JuvixError @FilesError)
|
||||
. runFilesIO
|
||||
. runReader entry
|
||||
. runPathResolverPipe
|
||||
|
@ -152,8 +152,7 @@ readPackageIO :: Path Abs Dir -> Path Abs Dir -> IO Package
|
||||
readPackageIO dir buildDir = do
|
||||
let x :: Sem '[Error Text, Files, Embed IO] Package
|
||||
x = readPackage dir buildDir
|
||||
m <- runM $ runError $ runFilesIO (runError x)
|
||||
m <- runM $ runFilesIO (runError x)
|
||||
case m of
|
||||
Left err -> runM (runReader defaultGenericOptions (printErrorAnsiSafe err)) >> exitFailure
|
||||
Right (Left err) -> putStrLn err >> exitFailure
|
||||
Right (Right r) -> return r
|
||||
Left err -> putStrLn err >> exitFailure
|
||||
Right r -> return r
|
||||
|
@ -1,5 +1,6 @@
|
||||
module Juvix.Data.Backends where
|
||||
|
||||
import Juvix.Data.WithLoc
|
||||
import Juvix.Prelude.Base
|
||||
|
||||
data Backend
|
||||
@ -10,10 +11,10 @@ data Backend
|
||||
instance Hashable Backend
|
||||
|
||||
data BackendItem = BackendItem
|
||||
{ _backendItemBackend :: Backend,
|
||||
{ _backendItemBackend :: WithLoc Backend,
|
||||
_backendItemCode :: Text
|
||||
}
|
||||
deriving stock (Show, Ord, Eq, Generic)
|
||||
deriving stock (Show, Ord, Eq, Generic, Data)
|
||||
|
||||
instance Hashable BackendItem
|
||||
|
||||
|
83
src/Juvix/Data/Comment.hs
Normal file
83
src/Juvix/Data/Comment.hs
Normal file
@ -0,0 +1,83 @@
|
||||
module Juvix.Data.Comment where
|
||||
|
||||
import Data.HashMap.Strict qualified as HashMap
|
||||
import Juvix.Data.Loc
|
||||
import Juvix.Prelude.Base
|
||||
import Path
|
||||
import Prettyprinter
|
||||
|
||||
newtype Comments = Comments
|
||||
{ _commentsByFile :: HashMap (Path Abs File) FileComments
|
||||
}
|
||||
deriving stock (Eq, Show, Generic, Data)
|
||||
|
||||
data FileComments = FileComments
|
||||
{ -- | sorted by position
|
||||
_fileCommentsSorted :: [Comment],
|
||||
_fileCommentsFile :: Path Abs File
|
||||
}
|
||||
deriving stock (Eq, Show, Generic, Data)
|
||||
|
||||
data CommentType
|
||||
= CommentOneLine
|
||||
| CommentBlock
|
||||
deriving stock (Eq, Ord, Show, Generic, Data)
|
||||
|
||||
data Comment = Comment
|
||||
{ _commentType :: CommentType,
|
||||
_commentText :: Text,
|
||||
_commentInterval :: Interval
|
||||
}
|
||||
deriving stock (Show, Eq, Ord, Generic, Data)
|
||||
|
||||
makeLenses ''Comment
|
||||
makeLenses ''FileComments
|
||||
makeLenses ''Comments
|
||||
|
||||
instance Pretty Comment where
|
||||
pretty :: Comment -> Doc ann
|
||||
pretty c = delim (pretty (c ^. commentText))
|
||||
where
|
||||
delim :: Doc ann -> Doc ann
|
||||
delim = case c ^. commentType of
|
||||
CommentOneLine -> ("--" <>)
|
||||
CommentBlock -> enclose "{-" "-}"
|
||||
|
||||
allComments :: Comments -> [Comment]
|
||||
allComments c = concat [f ^. fileCommentsSorted | f <- toList (c ^. commentsByFile)]
|
||||
|
||||
mkComments :: [Comment] -> Comments
|
||||
mkComments cs = Comments {..}
|
||||
where
|
||||
commentFile :: Comment -> Path Abs File
|
||||
commentFile = (^. commentInterval . intervalFile)
|
||||
_commentsByFile :: HashMap (Path Abs File) FileComments
|
||||
_commentsByFile =
|
||||
HashMap.fromList
|
||||
[ (_fileCommentsFile, FileComments {..})
|
||||
| filecomments :: NonEmpty Comment <- groupSortOn commentFile cs,
|
||||
let _fileCommentsFile = commentFile (head filecomments),
|
||||
let _fileCommentsSorted = sortOn (^. commentInterval) (toList filecomments)
|
||||
]
|
||||
|
||||
emptyComments :: Comments
|
||||
emptyComments = Comments mempty
|
||||
|
||||
emptyFileComments :: Path Abs File -> FileComments
|
||||
emptyFileComments _fileCommentsFile =
|
||||
FileComments
|
||||
{ _fileCommentsSorted = [],
|
||||
..
|
||||
}
|
||||
|
||||
fileComments :: Path Abs File -> Comments -> FileComments
|
||||
fileComments f cs = HashMap.lookupDefault (emptyFileComments f) f (cs ^. commentsByFile)
|
||||
|
||||
instance Pretty FileComments where
|
||||
pretty fc =
|
||||
pretty (fc ^. fileCommentsFile)
|
||||
<> line
|
||||
<> vsep [pretty c | c <- toList (fc ^. fileCommentsSorted)]
|
||||
|
||||
instance Pretty Comments where
|
||||
pretty c = vsep [pretty fc | fc <- toList (c ^. commentsByFile)]
|
102
src/Juvix/Data/Effect/ExactPrint.hs
Normal file
102
src/Juvix/Data/Effect/ExactPrint.hs
Normal file
@ -0,0 +1,102 @@
|
||||
module Juvix.Data.Effect.ExactPrint
|
||||
( module Juvix.Data.Effect.ExactPrint,
|
||||
module Juvix.Data.Effect.ExactPrint.Base,
|
||||
)
|
||||
where
|
||||
|
||||
import Juvix.Data.CodeAnn qualified as C
|
||||
import Juvix.Data.Effect.ExactPrint.Base
|
||||
import Juvix.Prelude.Base hiding ((<+>))
|
||||
import Juvix.Prelude.Pretty qualified as P
|
||||
|
||||
infixr 6 <+>
|
||||
|
||||
space :: Members '[ExactPrint] r => Sem r ()
|
||||
space = noLoc P.space
|
||||
|
||||
(<+>) :: Members '[ExactPrint] r => Sem r () -> Sem r () -> Sem r ()
|
||||
a <+> b = a >> noLoc P.space >> b
|
||||
|
||||
infixr 7 ?<>
|
||||
|
||||
(?<>) :: Maybe (Sem r ()) -> Sem r () -> Sem r ()
|
||||
(?<>) = maybe id (<>)
|
||||
|
||||
infixr 7 <?+>
|
||||
|
||||
(<?+>) :: Members '[ExactPrint] r => Maybe (Sem r ()) -> Sem r () -> Sem r ()
|
||||
(<?+>) = \case
|
||||
Nothing -> id
|
||||
Just a -> (a <+>)
|
||||
|
||||
infixl 7 <+?>
|
||||
|
||||
(<+?>) :: Members '[ExactPrint] r => Sem r () -> Maybe (Sem r ()) -> Sem r ()
|
||||
(<+?>) a = maybe a (a <+>)
|
||||
|
||||
-- NOTE that then you can use subsume indent' in the call site
|
||||
-- indent' :: forall ann r a. Sem (ExactPrint ann ': r) a -> Sem (ExactPrint ann ': r) a
|
||||
-- indent' = region @ann (P.indent 2)
|
||||
|
||||
parens :: Members '[ExactPrint] r => Sem r () -> Sem r ()
|
||||
parens = region C.parens
|
||||
|
||||
braces :: Members '[ExactPrint] r => Sem r () -> Sem r ()
|
||||
braces = region C.braces
|
||||
|
||||
nest :: Members '[ExactPrint] r => Sem r () -> Sem r ()
|
||||
nest = region (P.nest 2)
|
||||
|
||||
hang :: Members '[ExactPrint] r => Sem r () -> Sem r ()
|
||||
hang = region (P.hang 2)
|
||||
|
||||
align :: Members '[ExactPrint] r => Sem r () -> Sem r ()
|
||||
align = region P.align
|
||||
|
||||
indent :: Members '[ExactPrint] r => Sem r () -> Sem r ()
|
||||
indent = region (P.indent 2)
|
||||
|
||||
line :: Members '[ExactPrint] r => Sem r ()
|
||||
line = noLoc P.line
|
||||
|
||||
lbrace :: Members '[ExactPrint] r => Sem r ()
|
||||
lbrace = noLoc C.kwBraceL
|
||||
|
||||
rbrace :: Members '[ExactPrint] r => Sem r ()
|
||||
rbrace = noLoc C.kwBraceR
|
||||
|
||||
bracesIndent :: Members '[ExactPrint] r => Sem r () -> Sem r ()
|
||||
bracesIndent d = braces (line <> indent d <> line)
|
||||
|
||||
semicolon :: Members '[ExactPrint] r => Sem r ()
|
||||
semicolon = noLoc C.kwSemicolon
|
||||
|
||||
sequenceEndWith :: (Monad m, Foldable l) => m () -> l (m ()) -> m ()
|
||||
sequenceEndWith sep l = sequenceWith sep l >> sep
|
||||
|
||||
endSemicolon :: (Members '[ExactPrint] r, Functor l) => l (Sem r ()) -> l (Sem r ())
|
||||
endSemicolon = fmap (>> semicolon)
|
||||
|
||||
sequenceWith :: forall m l. (Monad m, Foldable l) => m () -> l (m ()) -> m ()
|
||||
sequenceWith sep = go . toList
|
||||
where
|
||||
go :: [m ()] -> m ()
|
||||
go = \case
|
||||
[] -> return ()
|
||||
[x] -> x
|
||||
(x : xs) -> x >> sep >> go xs
|
||||
|
||||
hsep :: (Members '[ExactPrint] r, Foldable l) => l (Sem r ()) -> Sem r ()
|
||||
hsep = sequenceWith space
|
||||
|
||||
vsep :: (Foldable l, Members '[ExactPrint] r) => l (Sem r ()) -> Sem r ()
|
||||
vsep = sequenceWith line
|
||||
|
||||
vsep2 :: (Foldable l, Members '[ExactPrint] r) => l (Sem r ()) -> Sem r ()
|
||||
vsep2 = sequenceWith (line >> line)
|
||||
|
||||
enclose :: Monad m => m () -> m () -> m () -> m ()
|
||||
enclose l r p = l >> p >> r
|
||||
|
||||
encloseSep :: (Monad m, Foldable f) => m () -> m () -> m () -> f (m ()) -> m ()
|
||||
encloseSep l r sep f = l >> sequenceWith sep f >> r
|
107
src/Juvix/Data/Effect/ExactPrint/Base.hs
Normal file
107
src/Juvix/Data/Effect/ExactPrint/Base.hs
Normal file
@ -0,0 +1,107 @@
|
||||
module Juvix.Data.Effect.ExactPrint.Base
|
||||
( module Juvix.Data.Effect.ExactPrint.Base,
|
||||
module Juvix.Data.Loc,
|
||||
module Juvix.Data.Comment,
|
||||
)
|
||||
where
|
||||
|
||||
import Juvix.Data.CodeAnn hiding (line')
|
||||
import Juvix.Data.Comment
|
||||
import Juvix.Data.Loc
|
||||
import Juvix.Prelude.Base
|
||||
import Prettyprinter qualified as P
|
||||
|
||||
data ExactPrint m a where
|
||||
NoLoc :: Doc Ann -> ExactPrint m ()
|
||||
Morpheme :: Interval -> Doc Ann -> ExactPrint m ()
|
||||
Region :: (Doc Ann -> Doc Ann) -> m b -> ExactPrint m b
|
||||
|
||||
makeSem ''ExactPrint
|
||||
|
||||
data Builder = Builder
|
||||
{ -- | comments sorted by starting location
|
||||
_builderComments :: [Comment],
|
||||
_builderDoc :: Doc Ann,
|
||||
_builderEnd :: FileLoc
|
||||
}
|
||||
|
||||
makeLenses ''Builder
|
||||
|
||||
runExactPrint :: FileComments -> Sem (ExactPrint ': r) x -> Sem r (Doc Ann, x)
|
||||
runExactPrint cs = fmap (first (^. builderDoc)) . runState ini . re
|
||||
where
|
||||
ini :: Builder
|
||||
ini =
|
||||
Builder
|
||||
{ _builderComments = cs ^. fileCommentsSorted,
|
||||
_builderDoc = mempty,
|
||||
_builderEnd = FileLoc 0 0 0
|
||||
}
|
||||
|
||||
execExactPrint :: FileComments -> Sem (ExactPrint ': r) x -> Sem r (Doc Ann)
|
||||
execExactPrint cs = fmap fst . runExactPrint cs
|
||||
|
||||
re :: forall r a. Sem (ExactPrint ': r) a -> Sem (State Builder ': r) a
|
||||
re = reinterpretH h
|
||||
where
|
||||
h ::
|
||||
forall rInitial x.
|
||||
ExactPrint (Sem rInitial) x ->
|
||||
Tactical ExactPrint (Sem rInitial) (State Builder ': r) x
|
||||
h = \case
|
||||
NoLoc p -> append' p >>= pureT
|
||||
Morpheme l p -> morpheme' l p >>= pureT
|
||||
Region f m -> do
|
||||
st0 :: Builder <- set builderDoc mempty <$> get
|
||||
m' <- runT m
|
||||
(st' :: Builder, fx) <- raise $ evalExactPrint' st0 m'
|
||||
|
||||
modify (over builderDoc (<> f (st' ^. builderDoc)))
|
||||
modify (set builderComments (st' ^. builderComments))
|
||||
modify (set builderEnd (st' ^. builderEnd))
|
||||
|
||||
return fx
|
||||
|
||||
evalExactPrint' :: Builder -> Sem (ExactPrint ': r) a -> Sem r (Builder, a)
|
||||
evalExactPrint' b = runState b . re
|
||||
|
||||
-- TODO add new lines?
|
||||
eprint :: forall r. Members '[State Builder] r => Interval -> Doc Ann -> Sem r ()
|
||||
eprint _loc doc = append' doc
|
||||
|
||||
-- where
|
||||
-- number of lines between two intervals. 0 if they are on the same line
|
||||
-- it is assumed that a comes before b (i.e. a < b)
|
||||
-- numLines :: Interval -> Interval -> Int
|
||||
-- numLines a b = intervalStartLine b - intervalEndLine a
|
||||
|
||||
append' :: forall r. Members '[State Builder] r => Doc Ann -> Sem r ()
|
||||
append' d = modify (over builderDoc (<> d))
|
||||
|
||||
line' :: forall r. Members '[State Builder] r => Sem r ()
|
||||
line' = append' P.line
|
||||
|
||||
morpheme' :: forall r. Members '[State Builder] r => Interval -> Doc Ann -> Sem r ()
|
||||
morpheme' loc doc = do
|
||||
mc <- popComment
|
||||
case mc of
|
||||
Nothing -> eprint loc doc
|
||||
Just c -> printComment c >> morpheme' loc doc
|
||||
where
|
||||
cmp :: Comment -> Bool
|
||||
cmp c = c ^. commentInterval . intervalStart < loc ^. intervalStart
|
||||
|
||||
printComment :: Comment -> Sem r ()
|
||||
printComment c = do
|
||||
eprint (c ^. commentInterval) (annotate AnnComment (P.pretty c))
|
||||
line'
|
||||
|
||||
popComment :: Sem r (Maybe Comment)
|
||||
popComment = do
|
||||
cs <- gets (^. builderComments)
|
||||
case cs of
|
||||
(h : hs)
|
||||
| cmp h -> do
|
||||
modify' (set builderComments hs)
|
||||
return (Just h)
|
||||
_ -> return Nothing
|
@ -1,6 +1,5 @@
|
||||
module Juvix.Data.Effect.Files
|
||||
( module Juvix.Data.Effect.Files.Error,
|
||||
module Juvix.Data.Effect.Files.Base,
|
||||
( module Juvix.Data.Effect.Files.Base,
|
||||
module Juvix.Data.Effect.Files.Pure,
|
||||
module Juvix.Data.Effect.Files.IO,
|
||||
module Juvix.Data.Effect.Files,
|
||||
@ -9,7 +8,6 @@ where
|
||||
|
||||
import Data.HashSet qualified as HashSet
|
||||
import Juvix.Data.Effect.Files.Base
|
||||
import Juvix.Data.Effect.Files.Error
|
||||
import Juvix.Data.Effect.Files.IO
|
||||
import Juvix.Data.Effect.Files.Pure (runFilesPure)
|
||||
import Juvix.Prelude.Base
|
||||
|
@ -1,11 +1,9 @@
|
||||
module Juvix.Data.Effect.Files.Base
|
||||
( module Juvix.Data.Effect.Files.Base,
|
||||
module Juvix.Data.Effect.Files.Error,
|
||||
module Juvix.Data.Uid,
|
||||
)
|
||||
where
|
||||
|
||||
import Juvix.Data.Effect.Files.Error
|
||||
import Juvix.Data.Uid
|
||||
import Juvix.Prelude.Base
|
||||
import Path
|
||||
|
@ -1,46 +0,0 @@
|
||||
module Juvix.Data.Effect.Files.Error where
|
||||
|
||||
import Juvix.Data.Error
|
||||
import Juvix.Data.Loc
|
||||
import Juvix.Prelude.Base
|
||||
import Juvix.Prelude.Pretty
|
||||
|
||||
data FilesErrorCause
|
||||
= StdlibConflict
|
||||
deriving stock (Show)
|
||||
|
||||
data FilesError = FilesError
|
||||
{ _filesErrorPath :: FilePath,
|
||||
_filesErrorCause :: FilesErrorCause
|
||||
}
|
||||
deriving stock (Show)
|
||||
|
||||
instance ToGenericError FilesError where
|
||||
genericError FilesError {..} =
|
||||
return
|
||||
GenericError
|
||||
{ _genericErrorLoc = i,
|
||||
_genericErrorMessage = AnsiText (pretty @_ @AnsiStyle msg),
|
||||
_genericErrorIntervals = [i]
|
||||
}
|
||||
where
|
||||
i :: Interval
|
||||
i =
|
||||
Interval
|
||||
{ _intervalFile = _filesErrorPath,
|
||||
_intervalStart = noFileLoc,
|
||||
_intervalEnd = noFileLoc
|
||||
}
|
||||
msg :: Text
|
||||
msg = case _filesErrorCause of
|
||||
StdlibConflict -> "The module defined in " <> pack _filesErrorPath <> " conflicts with a module defined in the standard library."
|
||||
|
||||
noFileLoc :: FileLoc
|
||||
noFileLoc =
|
||||
FileLoc
|
||||
{ _locLine = mempty,
|
||||
_locCol = mempty,
|
||||
_locOffset = mempty
|
||||
}
|
||||
|
||||
makeLenses ''FilesError
|
@ -16,10 +16,10 @@ runFilesIO ::
|
||||
forall r a.
|
||||
(Member (Embed IO) r) =>
|
||||
Sem (Files ': r) a ->
|
||||
Sem (Error FilesError ': r) a
|
||||
runFilesIO = reinterpret helper
|
||||
Sem r a
|
||||
runFilesIO = interpret helper
|
||||
where
|
||||
helper :: forall rInitial x. Files (Sem rInitial) x -> Sem (Error FilesError ': r) x
|
||||
helper :: forall rInitial x. Files (Sem rInitial) x -> Sem r x
|
||||
helper = \case
|
||||
ReadFile' f -> embed (readFile (toFilePath f))
|
||||
WriteFileBS p bs -> embed (ByteString.writeFile (toFilePath p) bs)
|
||||
|
@ -1,10 +1,13 @@
|
||||
module Juvix.Data.ForeignBlock where
|
||||
|
||||
import Juvix.Data.Backends
|
||||
import Juvix.Data.Keyword
|
||||
import Juvix.Data.WithLoc
|
||||
import Juvix.Prelude.Base
|
||||
|
||||
data ForeignBlock = ForeignBlock
|
||||
{ _foreignBackend :: Backend,
|
||||
{ _foreignKw :: KeywordRef,
|
||||
_foreignBackend :: WithLoc Backend,
|
||||
_foreignCode :: Text
|
||||
}
|
||||
deriving stock (Eq, Ord, Show, Data)
|
||||
|
@ -1,17 +1,49 @@
|
||||
module Juvix.Data.Keyword where
|
||||
|
||||
import Data.HashSet qualified as HashSet
|
||||
import Juvix.Prelude
|
||||
import Juvix.Data.Loc
|
||||
import Juvix.Prelude.Base
|
||||
import Juvix.Prelude.Pretty
|
||||
|
||||
data IsUnicode
|
||||
= Unicode
|
||||
| Ascii
|
||||
deriving stock (Eq, Show, Ord, Data)
|
||||
|
||||
data Keyword = Keyword
|
||||
{ _keywordAscii :: Text,
|
||||
_keywordUnicode :: Maybe Text,
|
||||
-- | true if _keywordAscii has a reserved character (the unicode is assumed to not have any)
|
||||
_keywordHasReserved :: Bool
|
||||
}
|
||||
deriving stock (Eq, Show, Ord, Data)
|
||||
|
||||
data KeywordRef = KeywordRef
|
||||
{ _keywordRefKeyword :: Keyword,
|
||||
_keywordRefInterval :: Interval,
|
||||
_keywordRefUnicode :: IsUnicode
|
||||
}
|
||||
deriving stock (Show, Data)
|
||||
|
||||
makeLenses ''Keyword
|
||||
makeLenses ''KeywordRef
|
||||
|
||||
instance Eq KeywordRef where
|
||||
a == b = a ^. keywordRefKeyword == b ^. keywordRefKeyword
|
||||
|
||||
instance Ord KeywordRef where
|
||||
compare a b = compare (a ^. keywordRefKeyword, a ^. keywordRefUnicode) (b ^. keywordRefKeyword, b ^. keywordRefUnicode)
|
||||
|
||||
instance HasLoc KeywordRef where
|
||||
getLoc = (^. keywordRefInterval)
|
||||
|
||||
instance Pretty KeywordRef where
|
||||
pretty r
|
||||
| Unicode <- r ^. keywordRefUnicode = pretty (fromJust (k ^. keywordUnicode))
|
||||
| otherwise = pretty (k ^. keywordAscii)
|
||||
where
|
||||
k :: Keyword
|
||||
k = r ^. keywordRefKeyword
|
||||
|
||||
-- | Unicode has preference
|
||||
instance Pretty Keyword where
|
||||
@ -20,6 +52,13 @@ instance Pretty Keyword where
|
||||
keywordsStrings :: [Keyword] -> HashSet Text
|
||||
keywordsStrings = HashSet.fromList . concatMap keywordStrings
|
||||
|
||||
-- | Nothing if it does not match.
|
||||
keywordMatch :: Keyword -> Text -> Maybe IsUnicode
|
||||
keywordMatch Keyword {..} t
|
||||
| Just t == _keywordUnicode = Just Unicode
|
||||
| t == _keywordAscii = Just Ascii
|
||||
| otherwise = Nothing
|
||||
|
||||
keywordStrings :: Keyword -> [Text]
|
||||
keywordStrings Keyword {..} = maybe id (:) _keywordUnicode [_keywordAscii]
|
||||
|
||||
|
@ -1,6 +1,7 @@
|
||||
module Juvix.Data.Loc where
|
||||
|
||||
import Juvix.Prelude.Base
|
||||
import Juvix.Prelude.Path
|
||||
import Prettyprinter
|
||||
import Text.Megaparsec qualified as M
|
||||
|
||||
@ -31,7 +32,7 @@ instance Ord FileLoc where
|
||||
|
||||
data Loc = Loc
|
||||
{ -- | Name of source file
|
||||
_locFile :: FilePath,
|
||||
_locFile :: Path Abs File,
|
||||
-- | Position within the file
|
||||
_locFileLoc :: !FileLoc
|
||||
}
|
||||
@ -39,7 +40,7 @@ data Loc = Loc
|
||||
|
||||
mkLoc :: Int -> M.SourcePos -> Loc
|
||||
mkLoc offset M.SourcePos {..} =
|
||||
let _locFile = normalise sourceName
|
||||
let _locFile = absFile' (normalise sourceName)
|
||||
in Loc {..}
|
||||
where
|
||||
_locOffset = Pos (fromIntegral offset)
|
||||
@ -47,13 +48,18 @@ mkLoc offset M.SourcePos {..} =
|
||||
where
|
||||
_locLine = fromPos sourceLine
|
||||
_locCol = fromPos sourceColumn
|
||||
absFile' :: FilePath -> Path Abs File
|
||||
absFile' fp = fromMaybe err (parseAbsFile fp)
|
||||
where
|
||||
err :: a
|
||||
err = error ("The path \"" <> pack fp <> "\" is not absolute. Remember to pass an absolute path to Megaparsec when running a parser")
|
||||
|
||||
fromPos :: M.Pos -> Pos
|
||||
fromPos = Pos . fromIntegral . M.unPos
|
||||
|
||||
-- | Inclusive interval
|
||||
data Interval = Interval
|
||||
{ _intervalFile :: FilePath,
|
||||
{ _intervalFile :: Path Abs File,
|
||||
_intervalStart :: FileLoc,
|
||||
_intervalEnd :: FileLoc
|
||||
}
|
||||
@ -88,6 +94,12 @@ singletonInterval l =
|
||||
intervalLength :: Interval -> Int
|
||||
intervalLength i = fromIntegral (i ^. intervalEnd . locOffset - i ^. intervalStart . locOffset) + 1
|
||||
|
||||
intervalEndLine :: Interval -> Int
|
||||
intervalEndLine a = a ^. intervalEnd . locLine . unPos . to fromIntegral
|
||||
|
||||
intervalStartLine :: Interval -> Int
|
||||
intervalStartLine a = a ^. intervalStart . locLine . unPos . to fromIntegral
|
||||
|
||||
intervalStartLoc :: Interval -> Loc
|
||||
intervalStartLoc i =
|
||||
Loc
|
||||
@ -99,6 +111,9 @@ mkInterval :: Loc -> Loc -> Interval
|
||||
mkInterval start end =
|
||||
Interval (start ^. locFile) (start ^. locFileLoc) (end ^. locFileLoc)
|
||||
|
||||
filterByLoc :: HasLoc p => Path Abs File -> [p] -> [p]
|
||||
filterByLoc p = filter ((== p) . (^. intervalFile) . getLoc)
|
||||
|
||||
instance Pretty Pos where
|
||||
pretty :: Pos -> Doc a
|
||||
pretty (Pos p) = pretty p
|
||||
|
@ -31,5 +31,12 @@ instance (Ord a) => Ord (WithLoc a) where
|
||||
instance Functor WithLoc where
|
||||
fmap = over withLocParam
|
||||
|
||||
instance (Pretty a) => Pretty (WithLoc a) where
|
||||
instance Foldable WithLoc where
|
||||
foldMap f (WithLoc _ a) = f a
|
||||
foldr f b (WithLoc _ a) = f a b
|
||||
|
||||
instance Traversable WithLoc where
|
||||
traverse f (WithLoc i a) = WithLoc i <$> f a
|
||||
|
||||
instance Pretty a => Pretty (WithLoc a) where
|
||||
pretty (WithLoc _ a) = pretty a
|
||||
|
@ -6,6 +6,7 @@ import Data.HashSet qualified as HashSet
|
||||
import Data.Set qualified as Set
|
||||
import Data.Text qualified as Text
|
||||
import GHC.Unicode
|
||||
import Juvix.Data.Comment
|
||||
import Juvix.Data.Keyword
|
||||
import Juvix.Extra.Strings qualified as Str
|
||||
import Juvix.Prelude
|
||||
@ -24,19 +25,34 @@ space1 = void $ takeWhile1P (Just "white space (only spaces and newlines allowed
|
||||
isWhiteSpace :: Char -> Bool
|
||||
isWhiteSpace = (`elem` [' ', '\n'])
|
||||
|
||||
space' :: forall r. Bool -> (forall a. ParsecS r a -> ParsecS r ()) -> ParsecS r ()
|
||||
space' judoc comment_ = L.space space1 lineComment block
|
||||
space' :: forall r. Bool -> ParsecS r [Comment]
|
||||
space' judoc = do
|
||||
catMaybes
|
||||
<$> P.many
|
||||
( hidden
|
||||
( choice
|
||||
[space1 $> Nothing, Just <$> (lineComment <|> blockComment)]
|
||||
)
|
||||
)
|
||||
where
|
||||
lineComment :: ParsecS r ()
|
||||
lineComment = comment_ $ do
|
||||
lineComment :: ParsecS r Comment
|
||||
lineComment = do
|
||||
let _commentType = CommentOneLine
|
||||
when
|
||||
judoc
|
||||
(notFollowedBy (P.chunk Str.judocStart))
|
||||
void (P.chunk "--")
|
||||
void (P.takeWhileP Nothing (/= '\n'))
|
||||
(_commentText, _commentInterval) <- interval $ do
|
||||
void (P.chunk "--")
|
||||
P.takeWhileP Nothing (/= '\n')
|
||||
return Comment {..}
|
||||
|
||||
block :: ParsecS r ()
|
||||
block = comment_ (L.skipBlockComment "{-" "-}")
|
||||
blockComment :: ParsecS r Comment
|
||||
blockComment = do
|
||||
let _commentType = CommentBlock
|
||||
(_commentText, _commentInterval) <- interval $ do
|
||||
void (P.chunk "{-")
|
||||
pack <$> P.manyTill anySingle (P.chunk "-}")
|
||||
return Comment {..}
|
||||
|
||||
integer' :: ParsecS r (Integer, Interval) -> ParsecS r (Integer, Interval)
|
||||
integer' dec = do
|
||||
@ -60,21 +76,24 @@ string' :: ParsecS r Text
|
||||
string' = pack <$> (char '"' >> manyTill L.charLiteral (char '"'))
|
||||
|
||||
-- | The caller is responsible of consuming space after it.
|
||||
kw' :: Keyword -> ParsecS r Interval
|
||||
kw' :: Keyword -> ParsecS r KeywordRef
|
||||
kw' k@Keyword {..} = P.label (unpack _keywordAscii) (reserved <|> normal)
|
||||
where
|
||||
-- If the ascii representation uses reserved symbols, we use chunk so that we parse exactly the keyword
|
||||
-- (if chunk fails it does not consume anything so try is not needed)
|
||||
reserved :: ParsecS r Interval
|
||||
reserved :: ParsecS r KeywordRef
|
||||
reserved
|
||||
| _keywordHasReserved = onlyInterval (P.chunk _keywordAscii)
|
||||
| _keywordHasReserved = do
|
||||
i <- onlyInterval (P.chunk _keywordAscii)
|
||||
return (KeywordRef k i Ascii)
|
||||
| otherwise = empty
|
||||
-- we parse the longest valid identifier and then we check if it is the expected keyword
|
||||
normal :: ParsecS r Interval
|
||||
normal :: ParsecS r KeywordRef
|
||||
normal = P.try $ do
|
||||
(w, i) <- interval morpheme
|
||||
unless (w `elem` keywordStrings k) (failure Nothing (Set.singleton (Label (fromJust $ nonEmpty $ unpack _keywordAscii))))
|
||||
return i
|
||||
case keywordMatch k w of
|
||||
Just u -> return (KeywordRef k i u)
|
||||
Nothing -> failure Nothing (Set.singleton (Label (fromJust $ nonEmpty $ unpack _keywordAscii)))
|
||||
|
||||
rawIdentifier' :: (Char -> Bool) -> HashSet Text -> ParsecS r Text
|
||||
rawIdentifier' excludedTailChar allKeywords = label "<identifier>" $ P.try $ do
|
||||
|
@ -7,11 +7,13 @@ import Juvix.Compiler.Concrete qualified as Concrete
|
||||
import Juvix.Compiler.Concrete.Extra
|
||||
import Juvix.Compiler.Concrete.Language
|
||||
import Juvix.Compiler.Concrete.Pretty qualified as M
|
||||
import Juvix.Compiler.Concrete.Print qualified as P
|
||||
import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver
|
||||
import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping qualified as Scoper
|
||||
import Juvix.Compiler.Concrete.Translation.FromSource qualified as Parser
|
||||
import Juvix.Compiler.Pipeline
|
||||
import Juvix.Compiler.Pipeline.Setup
|
||||
import Juvix.Data.Comment
|
||||
import Juvix.Prelude.Aeson
|
||||
import Juvix.Prelude.Pretty
|
||||
|
||||
@ -26,8 +28,11 @@ makeLenses ''PosTest
|
||||
root :: Path Abs Dir
|
||||
root = relToProject $(mkRelDir "tests/positive")
|
||||
|
||||
renderCode :: (M.PrettyCode c) => c -> Text
|
||||
renderCode = prettyText . M.ppOutDefault
|
||||
renderCodeOld :: M.PrettyCode c => c -> Text
|
||||
renderCodeOld = prettyText . M.ppOutDefault
|
||||
|
||||
renderCodeNew :: (HasLoc c, P.PrettyPrint c) => c -> Text
|
||||
renderCodeNew = prettyText . P.ppOutDefault emptyComments
|
||||
|
||||
type Pipe =
|
||||
'[ PathResolver,
|
||||
@ -39,91 +44,94 @@ type Pipe =
|
||||
Embed IO
|
||||
]
|
||||
|
||||
testDescr :: PosTest -> TestDescr
|
||||
testDescr PosTest {..} =
|
||||
let tRoot = root <//> _relDir
|
||||
file' = tRoot <//> _file
|
||||
in TestDescr
|
||||
{ _testName = _name,
|
||||
_testRoot = tRoot,
|
||||
_testAssertion = Steps $ \step -> do
|
||||
pkg <- readPackageIO tRoot (rootBuildDir tRoot)
|
||||
let entryPoint = entryPointFromPackage tRoot file' pkg
|
||||
runHelper :: HashMap (Path Abs File) Text -> Sem Pipe a -> IO (ResolverState, a)
|
||||
runHelper files =
|
||||
runM
|
||||
. runErrorIO' @JuvixError
|
||||
. runNameIdGen
|
||||
. runFilesPure files tRoot
|
||||
. runReader entryPoint
|
||||
. runPathResolverPipe
|
||||
evalHelper :: HashMap (Path Abs File) Text -> Sem Pipe a -> IO a
|
||||
evalHelper files = fmap snd . runHelper files
|
||||
testDescr :: PosTest -> [TestDescr]
|
||||
testDescr PosTest {..} = helper renderCodeOld "" : [helper renderCodeNew " (with comments)"]
|
||||
where
|
||||
helper :: (forall c. (HasLoc c, P.PrettyPrint c, M.PrettyCode c) => c -> Text) -> String -> TestDescr
|
||||
helper renderArg tag =
|
||||
let tRoot = root <//> _relDir
|
||||
file' = tRoot <//> _file
|
||||
in TestDescr
|
||||
{ _testName = _name <> tag,
|
||||
_testRoot = tRoot,
|
||||
_testAssertion = Steps $ \step -> do
|
||||
pkg <- readPackageIO tRoot (rootBuildDir tRoot)
|
||||
let entryPoint = entryPointFromPackage tRoot file' pkg
|
||||
runHelper :: HashMap (Path Abs File) Text -> Sem Pipe a -> IO (ResolverState, a)
|
||||
runHelper files =
|
||||
runM
|
||||
. runErrorIO' @JuvixError
|
||||
. runNameIdGen
|
||||
. runFilesPure files tRoot
|
||||
. runReader entryPoint
|
||||
. runPathResolverPipe
|
||||
evalHelper :: HashMap (Path Abs File) Text -> Sem Pipe a -> IO a
|
||||
evalHelper files = fmap snd . runHelper files
|
||||
|
||||
step "Parsing"
|
||||
p :: Parser.ParserResult <- snd <$> runIO' iniState entryPoint upToParsing
|
||||
step "Parsing"
|
||||
p :: Parser.ParserResult <- snd <$> runIO' iniState entryPoint upToParsing
|
||||
|
||||
let p2 :: Module 'Parsed 'ModuleTop = head (p ^. Parser.resultModules)
|
||||
let p2 :: Module 'Parsed 'ModuleTop = head (p ^. Parser.resultModules)
|
||||
|
||||
step "Scoping"
|
||||
(artif :: Artifacts, s :: Scoper.ScoperResult) <-
|
||||
runIO'
|
||||
iniState
|
||||
entryPoint
|
||||
( do
|
||||
void entrySetup
|
||||
Concrete.fromParsed p
|
||||
)
|
||||
step "Scoping"
|
||||
(artif :: Artifacts, s :: Scoper.ScoperResult) <-
|
||||
runIO'
|
||||
iniState
|
||||
entryPoint
|
||||
( do
|
||||
void entrySetup
|
||||
Concrete.fromParsed p
|
||||
)
|
||||
|
||||
let s2 = head (s ^. Scoper.resultModules)
|
||||
let s2 = head (s ^. Scoper.resultModules)
|
||||
|
||||
yamlFiles :: [(Path Abs File, Text)]
|
||||
yamlFiles =
|
||||
[ (pkgi ^. packageRoot <//> juvixYamlFile, encodeToText (rawPackage (pkgi ^. packagePackage)))
|
||||
| pkgi <- toList (artif ^. artifactResolver . resolverPackages)
|
||||
]
|
||||
fs :: HashMap (Path Abs File) Text
|
||||
fs =
|
||||
HashMap.fromList $
|
||||
[ (absFile (getModuleFileAbsPath (toFilePath tRoot) m), renderCode m)
|
||||
| m <- toList (getAllModules s2)
|
||||
]
|
||||
<> yamlFiles
|
||||
yamlFiles :: [(Path Abs File, Text)]
|
||||
yamlFiles =
|
||||
[ (pkgi ^. packageRoot <//> juvixYamlFile, encodeToText (rawPackage (pkgi ^. packagePackage)))
|
||||
| pkgi <- toList (artif ^. artifactResolver . resolverPackages)
|
||||
]
|
||||
fs :: HashMap (Path Abs File) Text
|
||||
fs =
|
||||
HashMap.fromList $
|
||||
[ (getModuleFilePath m, renderArg m)
|
||||
| m <- toList (getAllModules s2)
|
||||
]
|
||||
<> yamlFiles
|
||||
|
||||
let scopedPretty = renderCode s2
|
||||
parsedPretty = renderCode p2
|
||||
onlyMainFile :: Text -> HashMap (Path Abs File) Text
|
||||
onlyMainFile t = HashMap.fromList $ (file', t) : yamlFiles
|
||||
let scopedPretty = renderArg s2
|
||||
parsedPretty = renderCodeOld p2
|
||||
onlyMainFile :: Text -> HashMap (Path Abs File) Text
|
||||
onlyMainFile t = HashMap.fromList $ (file', t) : yamlFiles
|
||||
|
||||
step "Parsing pretty scoped"
|
||||
let fs2 = onlyMainFile scopedPretty
|
||||
p' :: Parser.ParserResult <- evalHelper fs2 upToParsing
|
||||
step "Parsing pretty scoped"
|
||||
let fs2 = onlyMainFile scopedPretty
|
||||
p' :: Parser.ParserResult <- evalHelper fs2 upToParsing
|
||||
|
||||
step "Parsing pretty parsed"
|
||||
let fs3 = onlyMainFile parsedPretty
|
||||
parsedPretty' :: Parser.ParserResult <- evalHelper fs3 upToParsing
|
||||
step "Parsing pretty parsed"
|
||||
let fs3 = onlyMainFile parsedPretty
|
||||
parsedPretty' :: Parser.ParserResult <- evalHelper fs3 upToParsing
|
||||
|
||||
step "Scoping the scoped"
|
||||
s' :: Scoper.ScoperResult <- evalHelper fs upToScoping
|
||||
step "Scoping the scoped"
|
||||
s' :: Scoper.ScoperResult <- evalHelper fs upToScoping
|
||||
|
||||
step "Checks"
|
||||
let smodules = s ^. Scoper.resultModules
|
||||
smodules' = s' ^. Scoper.resultModules
|
||||
step "Checks"
|
||||
let smodules = s ^. Scoper.resultModules
|
||||
smodules' = s' ^. Scoper.resultModules
|
||||
|
||||
let pmodules = p ^. Parser.resultModules
|
||||
pmodules' = p' ^. Parser.resultModules
|
||||
parsedPrettyModules = parsedPretty' ^. Parser.resultModules
|
||||
let pmodules = p ^. Parser.resultModules
|
||||
pmodules' = p' ^. Parser.resultModules
|
||||
parsedPrettyModules = parsedPretty' ^. Parser.resultModules
|
||||
|
||||
assertEqDiff "check: scope . parse . pretty . scope . parse = scope . parse" smodules smodules'
|
||||
assertEqDiff "check: parse . pretty . scope . parse = parse" pmodules pmodules'
|
||||
assertEqDiff "check: parse . pretty . parse = parse" pmodules parsedPrettyModules
|
||||
}
|
||||
assertEqDiff "check: scope . parse . pretty . scope . parse = scope . parse" smodules smodules'
|
||||
assertEqDiff "check: parse . pretty . scope . parse = parse" pmodules pmodules'
|
||||
assertEqDiff "check: parse . pretty . parse = parse" pmodules parsedPrettyModules
|
||||
}
|
||||
|
||||
allTests :: TestTree
|
||||
allTests =
|
||||
testGroup
|
||||
"Scope positive tests"
|
||||
(map (mkTest . testDescr) tests)
|
||||
(map mkTest (concatMap testDescr tests))
|
||||
|
||||
tests :: [PosTest]
|
||||
tests =
|
||||
|
@ -7,7 +7,7 @@ module A;
|
||||
end ;
|
||||
infix 2 +;
|
||||
axiom + : Type → Type → Type;
|
||||
end ;
|
||||
end;
|
||||
import M;
|
||||
f : M.N.T;
|
||||
f (_ M.N.t _) := Type M.+ Type;
|
||||
|
Loading…
Reference in New Issue
Block a user