Skip to content

Commit

Permalink
remove old named application syntax
Browse files Browse the repository at this point in the history
  • Loading branch information
janmasrovira committed Sep 12, 2024
1 parent 56e2db7 commit b8e9a06
Show file tree
Hide file tree
Showing 12 changed files with 131 additions and 284 deletions.
1 change: 0 additions & 1 deletion src/Juvix/Compiler/Concrete/Data/NameSignature/Builder.hs
Original file line number Diff line number Diff line change
Expand Up @@ -11,7 +11,6 @@ module Juvix.Compiler.Concrete.Data.NameSignature.Builder
where

import Juvix.Compiler.Concrete.Data.NameSignature.Error
import Juvix.Compiler.Concrete.Extra (symbolParsed)
import Juvix.Compiler.Concrete.Gen qualified as Gen
import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping.Error
import Juvix.Prelude
Expand Down
5 changes: 0 additions & 5 deletions src/Juvix/Compiler/Concrete/Extra.hs
Original file line number Diff line number Diff line change
Expand Up @@ -82,11 +82,6 @@ groupStatements = \case
^. S.nameConcrete
: map (^. constructorName . S.nameConcrete) constructors

symbolParsed :: forall s. (SingI s) => SymbolType s -> Symbol
symbolParsed sym = case sing :: SStage s of
SParsed -> sym
SScoped -> sym ^. S.nameConcrete

flattenStatement :: Statement s -> [Statement s]
flattenStatement = \case
StatementModule m -> concatMap flattenStatement (m ^. moduleBody)
Expand Down
63 changes: 29 additions & 34 deletions src/Juvix/Compiler/Concrete/Gen.hs
Original file line number Diff line number Diff line change
Expand Up @@ -18,6 +18,11 @@ kw k = do
_keywordRefInterval = loc
}

simplestFunctionDefParsed :: (Member (Reader Interval) r) => Text -> NonEmpty (ExpressionAtom 'Parsed) -> Sem r (FunctionDef 'Parsed)
simplestFunctionDefParsed funNameTxt funBody = do
funName <- symbol funNameTxt
return (simplestFunctionDef funName (mkExpressionAtoms funBody))

simplestFunctionDef :: FunctionName s -> ExpressionType s -> FunctionDef s
simplestFunctionDef funName funBody =
FunctionDef
Expand Down Expand Up @@ -60,18 +65,18 @@ symbol t = do
l <- ask
return (WithLoc l t)

mkExpressionAtoms :: NonEmpty (ExpressionAtom 'Parsed) -> ExpressionAtoms 'Parsed
mkExpressionAtoms _expressionAtoms =
ExpressionAtoms
{ _expressionAtoms,
_expressionAtomsLoc = Irrelevant (getLocSpan _expressionAtoms)
}

expressionAtoms' :: (Member (Reader Interval) r) => NonEmpty (ExpressionAtom 'Parsed) -> Sem r (ExpressionAtoms 'Parsed)
expressionAtoms' _expressionAtoms = do
_expressionAtomsLoc <- Irrelevant <$> ask
return ExpressionAtoms {..}

namedArgument :: (Member (Reader Interval) r) => Text -> NonEmpty (ExpressionAtom 'Parsed) -> Sem r (NamedArgumentAssign 'Parsed)
namedArgument n as = do
_namedArgValue <- expressionAtoms' as
_namedArgName <- symbol n
_namedArgAssignKw <- Irrelevant <$> kw kwAssign
return NamedArgumentAssign {..}

literalString :: (Member (Reader Interval) r) => Text -> Sem r (ExpressionAtom s)
literalString t = do
l <- ask
Expand All @@ -85,35 +90,25 @@ braced a = do
l <- ask
AtomBraces . WithLoc l <$> expressionAtoms' a

argumentBlock :: (Member (Reader Interval) r) => IsImplicit -> NonEmpty (NamedArgumentAssign 'Parsed) -> Sem r (ArgumentBlock 'Parsed)
argumentBlock i as = do
parenL <- kw delimL
parenR <- kw delimR
mkIsExhaustive :: (Member (Reader Interval) r) => Bool -> Sem r IsExhaustive
mkIsExhaustive _isExhaustive = do
keyw <-
if
| _isExhaustive -> kw kwAt
| otherwise -> kw kwAtQuestion
return
ArgumentBlock
{ _argBlockImplicit = i,
_argBlockDelims = Irrelevant (Just (parenL, parenR)),
_argBlockArgs = as
IsExhaustive
{ _isExhaustiveKw = Irrelevant keyw,
_isExhaustive
}
where
delimL :: Keyword
delimL = case i of
Explicit -> kwBracketL
Implicit -> delimBraceL
ImplicitInstance -> delimDoubleBraceL

delimR :: Keyword
delimR = case i of
Explicit -> kwBracketR
Implicit -> delimBraceR
ImplicitInstance -> delimDoubleBraceR

namedApplication :: Name -> NonEmpty (ArgumentBlock 'Parsed) -> ExpressionAtom 'Parsed
namedApplication n as =
AtomNamedApplication
NamedApplication
{ _namedAppName = n,
_namedAppArgs = as

namedApplication :: Name -> IsExhaustive -> [NamedArgumentNew 'Parsed] -> ExpressionAtom 'Parsed
namedApplication n exh as =
AtomNamedApplicationNew
NamedApplicationNew
{ _namedApplicationNewName = n,
_namedApplicationNewExhaustive = exh,
_namedApplicationNewArguments = as
}

literalInteger :: (Member (Reader Interval) r, Integral a) => a -> Sem r (ExpressionAtom 'Parsed)
Expand Down
111 changes: 61 additions & 50 deletions src/Juvix/Compiler/Concrete/Language/Base.hs
Original file line number Diff line number Diff line change
Expand Up @@ -1502,7 +1502,6 @@ data Expression
| ExpressionBraces (WithLoc Expression)
| ExpressionDoubleBraces (DoubleBracesExpression 'Scoped)
| ExpressionIterator (Iterator 'Scoped)
| ExpressionNamedApplication (NamedApplication 'Scoped)
| ExpressionNamedApplicationNew (NamedApplicationNew 'Scoped)
deriving stock (Show, Eq, Ord, Generic)

Expand Down Expand Up @@ -2327,32 +2326,6 @@ instance Serialize RecordUpdateApp

instance NFData RecordUpdateApp

data NamedApplication (s :: Stage) = NamedApplication
{ _namedAppName :: IdentifierType s,
_namedAppArgs :: NonEmpty (ArgumentBlock s)
}
deriving stock (Generic)

instance Serialize (NamedApplication 'Scoped)

instance NFData (NamedApplication 'Scoped)

instance Serialize (NamedApplication 'Parsed)

instance NFData (NamedApplication 'Parsed)

deriving stock instance Show (NamedApplication 'Parsed)

deriving stock instance Show (NamedApplication 'Scoped)

deriving stock instance Eq (NamedApplication 'Parsed)

deriving stock instance Eq (NamedApplication 'Scoped)

deriving stock instance Ord (NamedApplication 'Parsed)

deriving stock instance Ord (NamedApplication 'Scoped)

newtype NamedArgumentFunctionDef (s :: Stage) = NamedArgumentFunctionDef
{ _namedArgumentFunctionDef :: FunctionDef s
}
Expand Down Expand Up @@ -2608,7 +2581,6 @@ data ExpressionAtom (s :: Stage)
| AtomLiteral LiteralLoc
| AtomParens (ExpressionType s)
| AtomIterator (Iterator s)
| AtomNamedApplication (NamedApplication s)
| AtomNamedApplicationNew (NamedApplicationNew s)
deriving stock (Generic)

Expand Down Expand Up @@ -2902,7 +2874,6 @@ makeLenses ''Initializer
makeLenses ''Range
makeLenses ''ArgumentBlock
makeLenses ''NamedArgumentAssign
makeLenses ''NamedApplication
makeLenses ''NamedArgumentNew
makeLenses ''NamedApplicationNew
makeLenses ''AliasDef
Expand Down Expand Up @@ -2988,9 +2959,6 @@ instance (SingI s) => HasLoc (ArgumentBlock s) where
instance HasAtomicity (ArgumentBlock s) where
atomicity = const Atom

instance HasAtomicity (NamedApplication s) where
atomicity = const (Aggregate appFixity)

instance HasAtomicity (NamedApplicationNew s) where
atomicity = const (Aggregate updateFixity)

Expand Down Expand Up @@ -3018,7 +2986,6 @@ instance HasAtomicity Expression where
ExpressionCase c -> atomicity c
ExpressionIf x -> atomicity x
ExpressionIterator i -> atomicity i
ExpressionNamedApplication i -> atomicity i
ExpressionNamedApplicationNew i -> atomicity i
ExpressionRecordUpdate {} -> Aggregate updateFixity
ExpressionParensRecordUpdate {} -> Atom
Expand Down Expand Up @@ -3101,30 +3068,33 @@ instance HasLoc InfixApplication where
instance HasLoc PostfixApplication where
getLoc (PostfixApplication l o) = getLoc l <> getLoc o

instance HasLoc (LambdaClause 'Scoped) where
instance (SingI s) => HasLoc (LambdaClause s) where
getLoc c =
fmap getLoc (c ^. lambdaPipe . unIrrelevant)
?<> getLocSpan (c ^. lambdaParameters)
<> getLoc (c ^. lambdaBody)

instance HasLoc (Lambda 'Scoped) where
let locparams = case sing :: SStage s of
SParsed -> getLocSpan (c ^. lambdaParameters)
SScoped -> getLocSpan (c ^. lambdaParameters)
in fmap getLoc (c ^. lambdaPipe . unIrrelevant)
?<> locparams
<> getLocExpressionType (c ^. lambdaBody)

instance HasLoc (Lambda s) where
getLoc l = getLoc (l ^. lambdaKw) <> getLoc (l ^. lambdaBraces . unIrrelevant . _2)

instance HasLoc (FunctionParameter 'Scoped) where
instance (SingI s) => HasLoc (FunctionParameter s) where
getLoc = \case
FunctionParameterName n -> getLoc n
FunctionParameterName n -> getLocSymbolType n
FunctionParameterWildcard w -> getLoc w

instance HasLoc (FunctionParameters 'Scoped) where
instance (SingI s) => HasLoc (FunctionParameters s) where
getLoc p = case p ^. paramDelims . unIrrelevant of
Nothing -> (getLoc <$> listToMaybe (p ^. paramNames)) ?<> getLoc (p ^. paramType)
Nothing -> (getLoc <$> listToMaybe (p ^. paramNames)) ?<> getLocExpressionType (p ^. paramType)
Just (l, r) -> getLoc l <> getLoc r

instance HasLoc (Function 'Scoped) where
getLoc f = getLoc (f ^. funParameters) <> getLoc (f ^. funReturn)
instance (SingI s) => HasLoc (Function s) where
getLoc f = getLoc (f ^. funParameters) <> getLocExpressionType (f ^. funReturn)

instance HasLoc (Let 'Scoped) where
getLoc l = getLoc (l ^. letKw) <> getLoc (l ^. letExpression)
instance (SingI s) => HasLoc (Let s) where
getLoc l = getLoc (l ^. letKw) <> getLocExpressionType (l ^. letExpression)

instance (SingI s) => HasLoc (SideIfBranch s k) where
getLoc SideIfBranch {..} =
Expand Down Expand Up @@ -3166,8 +3136,13 @@ instance (SingI s) => HasLoc (If s) where
instance HasLoc (List s) where
getLoc List {..} = getLoc _listBracketL <> getLoc _listBracketR

instance (SingI s) => HasLoc (NamedApplication s) where
getLoc NamedApplication {..} = getLocIdentifierType _namedAppName <> getLoc (last _namedAppArgs)
instance (SingI s) => HasLoc (NamedArgumentFunctionDef s) where
getLoc (NamedArgumentFunctionDef f) = getLoc f

instance (SingI s) => HasLoc (NamedArgumentNew s) where
getLoc = \case
NamedArgumentNewFunction f -> getLoc f
NamedArgumentItemPun f -> getLoc f

instance HasLoc (NamedArgumentPun s) where
getLoc NamedArgumentPun {..} = getLocSymbolType _namedArgumentPunSymbol
Expand Down Expand Up @@ -3220,7 +3195,6 @@ instance HasLoc Expression where
ExpressionBraces i -> getLoc i
ExpressionDoubleBraces i -> getLoc i
ExpressionIterator i -> getLoc i
ExpressionNamedApplication i -> getLoc i
ExpressionNamedApplicationNew i -> getLoc i
ExpressionRecordUpdate i -> getLoc i
ExpressionParensRecordUpdate i -> getLoc i
Expand Down Expand Up @@ -3275,6 +3249,11 @@ getLocSymbolType = case sing :: SStage s of
SParsed -> getLoc
SScoped -> getLoc

getLocHoleType :: forall s. (SingI s) => HoleType s -> Interval
getLocHoleType = case sing :: SStage s of
SParsed -> getLoc
SScoped -> getLoc

getLocExpressionType :: forall s. (SingI s) => ExpressionType s -> Interval
getLocExpressionType = case sing :: SStage s of
SParsed -> getLoc
Expand Down Expand Up @@ -3419,6 +3398,28 @@ instance HasLoc Pattern where
PatternPostfixApplication i -> getLoc i
PatternRecord i -> getLoc i

instance (SingI s) => HasLoc (ExpressionAtom s) where
getLoc = \case
AtomIdentifier i -> getLocIdentifierType i
AtomLambda x -> getLoc x
AtomList x -> getLoc x
AtomCase x -> getLoc x
AtomIf x -> getLoc x
AtomHole x -> getLocHoleType x
AtomInstanceHole x -> getLocHoleType x
AtomDoubleBraces x -> getLoc x
AtomBraces x -> getLoc x
AtomDo x -> getLoc x
AtomLet x -> getLoc x
AtomRecordUpdate x -> getLoc x
AtomUniverse x -> getLoc x
AtomFunction x -> getLoc x
AtomFunArrow x -> getLoc x
AtomLiteral x -> getLoc x
AtomParens x -> getLocExpressionType x
AtomIterator x -> getLoc x
AtomNamedApplicationNew x -> getLoc x

instance HasLoc (ExpressionAtoms s) where
getLoc = getLoc . (^. expressionAtomsLoc)

Expand Down Expand Up @@ -3462,6 +3463,16 @@ _RecordStatementField f x = case x of
RecordStatementField p -> RecordStatementField <$> f p
_ -> pure x

symbolParsed :: forall s. (SingI s) => SymbolType s -> Symbol
symbolParsed sym = case sing :: SStage s of
SParsed -> sym
SScoped -> sym ^. S.nameConcrete

namedArgumentNewSymbolParsed :: (SingI s) => SimpleGetter (NamedArgumentNew s) Symbol
namedArgumentNewSymbolParsed = to $ \case
NamedArgumentItemPun a -> a ^. namedArgumentPunSymbol
NamedArgumentNewFunction a -> symbolParsed (a ^. namedArgumentFunctionDef . signName)

namedArgumentNewSymbol :: Lens' (NamedArgumentNew 'Parsed) Symbol
namedArgumentNewSymbol f = \case
NamedArgumentItemPun a -> NamedArgumentItemPun <$> namedArgumentPunSymbol f a
Expand Down
7 changes: 0 additions & 7 deletions src/Juvix/Compiler/Concrete/Language/IsApeInstances.hs
Original file line number Diff line number Diff line change
Expand Up @@ -4,7 +4,6 @@ module Juvix.Compiler.Concrete.Language.IsApeInstances where

import Juvix.Compiler.Concrete.Data.ScopedName qualified as S
import Juvix.Compiler.Concrete.Language.Base
import Juvix.Compiler.Concrete.MigrateNamedApplication
import Juvix.Data.Ape.Base as Ape
import Juvix.Data.NameKind
import Juvix.Parser.Lexer (isDelimiterStr)
Expand Down Expand Up @@ -82,11 +81,6 @@ instance IsApe Name ApeLeaf where
_leafExpr = ApeLeafAtom (sing :&: AtomIdentifier n)
}

instance (SingI s) => IsApe (NamedApplication s) ApeLeaf where
toApe = toApe . migrateNamedApplication

-- f = toApeIdentifierType _namedAppName

instance (SingI s) => IsApe (NamedApplicationNew s) ApeLeaf where
toApe a =
ApeLeaf $
Expand Down Expand Up @@ -150,7 +144,6 @@ instance IsApe Expression ApeLeaf where
ExpressionInfixApplication a -> toApe a
ExpressionPostfixApplication a -> toApe a
ExpressionFunction a -> toApe a
ExpressionNamedApplication a -> toApe a
ExpressionNamedApplicationNew a -> toApe a
ExpressionRecordUpdate a -> toApe a
ExpressionParensRecordUpdate {} -> leaf
Expand Down
29 changes: 0 additions & 29 deletions src/Juvix/Compiler/Concrete/MigrateNamedApplication.hs

This file was deleted.

Loading

0 comments on commit b8e9a06

Please sign in to comment.