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
janmasrovira committed Sep 12, 2024
1 parent 26ea94b commit 13ed3be
Show file tree
Hide file tree
Showing 9 changed files with 114 additions and 267 deletions.
50 changes: 14 additions & 36 deletions src/Juvix/Compiler/Concrete/Gen.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -60,18 +60,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 +85,13 @@ 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
return
ArgumentBlock
{ _argBlockImplicit = i,
_argBlockDelims = Irrelevant (Just (parenL, parenR)),
_argBlockArgs = as
}
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 -> [NamedArgumentNew 'Parsed] -> IsExhaustive -> ExpressionAtom 'Parsed
namedApplication n as exh =
AtomNamedApplicationNew
NamedApplicationNew
{ _namedApplicationNewName = n,
_namedApplicationNewExhaustive = exh,
_namedApplicationNewArguments = as
}

literalInteger :: (Member (Reader Interval) r, Integral a) => a -> Sem r (ExpressionAtom 'Parsed)
Expand Down
174 changes: 76 additions & 98 deletions src/Juvix/Compiler/Concrete/Language/Base.hs
View file
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 @@ -2214,59 +2213,59 @@ deriving stock instance Ord (List 'Parsed)

deriving stock instance Ord (List 'Scoped)

data NamedArgumentAssign (s :: Stage) = NamedArgumentAssign
{ _namedArgName :: SymbolType s,
_namedArgAssignKw :: Irrelevant KeywordRef,
_namedArgValue :: ExpressionType s
}
deriving stock (Generic)
-- data NamedArgumentAssign (s :: Stage) = NamedArgumentAssign
-- { _namedArgName :: SymbolType s,
-- _namedArgAssignKw :: Irrelevant KeywordRef,
-- _namedArgValue :: ExpressionType s
-- }
-- deriving stock (Generic)

instance Serialize (NamedArgumentAssign 'Scoped)
-- instance Serialize (NamedArgumentAssign 'Scoped)

instance NFData (NamedArgumentAssign 'Scoped)
-- instance NFData (NamedArgumentAssign 'Scoped)

instance Serialize (NamedArgumentAssign 'Parsed)
-- instance Serialize (NamedArgumentAssign 'Parsed)

instance NFData (NamedArgumentAssign 'Parsed)
-- instance NFData (NamedArgumentAssign 'Parsed)

deriving stock instance Show (NamedArgumentAssign 'Parsed)
-- deriving stock instance Show (NamedArgumentAssign 'Parsed)

deriving stock instance Show (NamedArgumentAssign 'Scoped)
-- deriving stock instance Show (NamedArgumentAssign 'Scoped)

deriving stock instance Eq (NamedArgumentAssign 'Parsed)
-- deriving stock instance Eq (NamedArgumentAssign 'Parsed)

deriving stock instance Eq (NamedArgumentAssign 'Scoped)
-- deriving stock instance Eq (NamedArgumentAssign 'Scoped)

deriving stock instance Ord (NamedArgumentAssign 'Parsed)
-- deriving stock instance Ord (NamedArgumentAssign 'Parsed)

deriving stock instance Ord (NamedArgumentAssign 'Scoped)
-- deriving stock instance Ord (NamedArgumentAssign 'Scoped)

data ArgumentBlock (s :: Stage) = ArgumentBlock
{ _argBlockDelims :: Irrelevant (Maybe (KeywordRef, KeywordRef)),
_argBlockImplicit :: IsImplicit,
_argBlockArgs :: NonEmpty (NamedArgumentAssign s)
}
deriving stock (Generic)
-- data ArgumentBlock (s :: Stage) = ArgumentBlock
-- { _argBlockDelims :: Irrelevant (Maybe (KeywordRef, KeywordRef)),
-- _argBlockImplicit :: IsImplicit,
-- _argBlockArgs :: NonEmpty (NamedArgumentAssign s)
-- }
-- deriving stock (Generic)

instance Serialize (ArgumentBlock 'Scoped)
-- instance Serialize (ArgumentBlock 'Scoped)

instance NFData (ArgumentBlock 'Scoped)
-- instance NFData (ArgumentBlock 'Scoped)

instance Serialize (ArgumentBlock 'Parsed)
-- instance Serialize (ArgumentBlock 'Parsed)

instance NFData (ArgumentBlock 'Parsed)
-- instance NFData (ArgumentBlock 'Parsed)

deriving stock instance Show (ArgumentBlock 'Parsed)
-- deriving stock instance Show (ArgumentBlock 'Parsed)

deriving stock instance Show (ArgumentBlock 'Scoped)
-- deriving stock instance Show (ArgumentBlock 'Scoped)

deriving stock instance Eq (ArgumentBlock 'Parsed)
-- deriving stock instance Eq (ArgumentBlock 'Parsed)

deriving stock instance Eq (ArgumentBlock 'Scoped)
-- deriving stock instance Eq (ArgumentBlock 'Scoped)

deriving stock instance Ord (ArgumentBlock 'Parsed)
-- deriving stock instance Ord (ArgumentBlock 'Parsed)

deriving stock instance Ord (ArgumentBlock 'Scoped)
-- deriving stock instance Ord (ArgumentBlock 'Scoped)

data RecordUpdateExtra = RecordUpdateExtra
{ _recordUpdateExtraConstructor :: S.Symbol,
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 @@ -2900,9 +2872,6 @@ makeLenses ''ExpressionAtoms
makeLenses ''Iterator
makeLenses ''Initializer
makeLenses ''Range
makeLenses ''ArgumentBlock
makeLenses ''NamedArgumentAssign
makeLenses ''NamedApplication
makeLenses ''NamedArgumentNew
makeLenses ''NamedApplicationNew
makeLenses ''AliasDef
Expand Down Expand Up @@ -2975,22 +2944,6 @@ instance (SingI s) => HasLoc (SyntaxDef s) where
SyntaxIterator t -> getLoc t
SyntaxAlias t -> getLoc t

instance (SingI s) => HasLoc (NamedArgumentAssign s) where
getLoc NamedArgumentAssign {..} = getLocSymbolType _namedArgName <> getLocExpressionType _namedArgValue

instance (SingI s) => HasLoc (ArgumentBlock s) where
getLoc ArgumentBlock {..} = case d of
Just (l, r) -> getLoc l <> getLoc r
Nothing -> getLocSpan _argBlockArgs
where
Irrelevant d = _argBlockDelims

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 +2971,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 +3053,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,9 +3121,6 @@ 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 HasLoc (NamedArgumentPun s) where
getLoc NamedArgumentPun {..} = getLocSymbolType _namedArgumentPunSymbol

Expand Down Expand Up @@ -3220,7 +3172,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 +3226,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 +3375,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
7 changes: 0 additions & 7 deletions src/Juvix/Compiler/Concrete/Language/IsApeInstances.hs
View file
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
Loading

0 comments on commit 13ed3be

Please sign in to comment.