-- |
-- Reification of language levels at marker positions.
module Record.Syntax.LevelReifier.Levels where

import Record.Syntax.Prelude hiding (exp, bracket)
import Record.Syntax.Shared
import qualified Language.Haskell.Exts as E


type Levels =
  [Level]

module_ :: E.Module -> Levels
module_ (E.Module _ _ _ _ _ _ decls) =
  foldMap decl decls

decl :: E.Decl -> Levels
decl = 
  \case
    E.TypeDecl _ _ _ t -> type_ t
    E.TypeFamDecl {} -> mempty
    E.ClosedTypeFamDecl _ _ _ _ tl -> foldMap typeEqn tl
    E.DataDecl _ _ c _ _ q d -> level c <> foldMap qualConDecl q <> foldMap deriving_ d
    E.GDataDecl _ _ c _ _ _ g d -> level c <> foldMap gadtDecl g <> foldMap deriving_ d
    E.DataFamDecl _ c _ _ _ -> level c
    E.TypeInsDecl _ t1 t2 -> type_ t1 <> type_ t2
    E.DataInsDecl _ _ t q d -> type_ t <> foldMap qualConDecl q <> foldMap deriving_ d
    E.GDataInsDecl _ _ t _ g d -> type_ t <> foldMap gadtDecl g <> foldMap deriving_ d
    E.ClassDecl _ c _ _ _ cd -> level c <> foldMap classDecl cd
    E.InstDecl _ _ _ c _ tl idl -> level c <> foldMap type_ tl <> foldMap instDecl idl
    E.DerivDecl _ _ _ c _ tl -> level c <> foldMap type_ tl
    E.InfixDecl {} -> mempty
    E.DefaultDecl _ tl -> foldMap type_ tl
    E.SpliceDecl _ e -> exp e
    E.TypeSig _ _ t -> type_ t
    E.FunBind ml -> foldMap match ml
    E.PatBind _ p r b -> pat p <> rhs r <> binds b
    E.ForImp _ _ _ _ _ t -> type_ t
    E.ForExp _ _ _ _ t -> type_ t
    E.RulePragmaDecl _ rl -> foldMap rule rl
    E.DeprPragmaDecl {} -> mempty
    E.WarnPragmaDecl {} -> mempty
    E.InlineSig {} -> mempty
    E.InlineConlikeSig {} -> mempty
    E.SpecSig _ _ _ tl -> foldMap type_ tl
    E.SpecInlineSig _ _ _ _ tl -> foldMap type_ tl
    E.InstSig _ _ c _ tl -> level c <> foldMap type_ tl
    E.AnnPragma {} -> mempty
    E.MinimalPragma {} -> mempty

rule :: E.Rule -> Levels
rule =
  \(E.Rule _ _ rvm e1 e2) -> (foldMap . foldMap) ruleVar rvm <> exp e1 <> exp e2

ruleVar :: E.RuleVar -> Levels
ruleVar =
  \case
    E.RuleVar _ -> mempty
    E.TypedRuleVar _ t -> type_ t

match :: E.Match -> Levels
match =
  \(E.Match _ _ pl tm r b) ->
    foldMap pat pl <> foldMap type_ tm <> rhs r <> binds b

rhs :: E.Rhs -> Levels
rhs =
  \case
    E.UnGuardedRhs e -> exp e
    E.GuardedRhss gl -> foldMap guardedRhs gl

guardedRhs :: E.GuardedRhs -> Levels
guardedRhs =
  \(E.GuardedRhs _ sl e) -> foldMap stmt sl <> exp e

instDecl :: E.InstDecl -> Levels
instDecl =
  \case
    E.InsDecl d -> decl d
    E.InsType _ t1 t2 -> type_ t1 <> type_ t2
    E.InsData _ _ t qcdl dl -> type_ t <> foldMap qualConDecl qcdl <> foldMap deriving_ dl
    E.InsGData _ _ t _ gdl dl -> type_ t <> foldMap gadtDecl gdl <> foldMap deriving_ dl

classDecl :: E.ClassDecl -> Levels
classDecl =
  \case
    E.ClsDecl d -> decl d
    E.ClsDataFam _ c _ _ _ -> level c
    E.ClsTyFam _ _ _ _ -> mempty
    E.ClsTyDef _ t1 t2 -> type_ t1 <> type_ t2
    E.ClsDefSig _ _ t -> type_ t

gadtDecl :: E.GadtDecl -> Levels
gadtDecl =
  \(E.GadtDecl _ _ pl t) -> foldMap (type_ . snd) pl <> type_ t

qualConDecl :: E.QualConDecl -> Levels
qualConDecl =
  \(E.QualConDecl _ _ c cd) -> level c <> conDecl cd

conDecl :: E.ConDecl -> Levels
conDecl =
  \case
    E.ConDecl _ tl -> foldMap type_ tl
    E.InfixConDecl t1 _ t2 -> type_ t1 <> type_ t2
    E.RecDecl {} -> error "Unexpected record declaration"

typeEqn :: E.TypeEqn -> Levels
typeEqn =
  \(E.TypeEqn t1 t2) -> type_ t1 <> type_ t2

deriving_ :: E.Deriving -> Levels
deriving_ =
  \(_, tl) -> foldMap type_ tl

type_ :: E.Type -> Levels
type_ =
  \case
    E.TyForall _ c t -> level c <> type_ t
    E.TyFun t1 t2 -> type_ t1 <> type_ t2
    E.TyTuple _ tl -> foldMap type_ tl
    E.TyList t -> type_ t
    E.TyParArray t -> type_ t
    E.TyApp t1 t2 -> type_ t1 <> type_ t2
    E.TyVar _ -> mempty
    E.TyCon n -> qName Level_Type n
    E.TyParen t -> type_ t
    E.TyInfix t1 _ t2 -> type_ t1 <> type_ t2
    E.TyKind t _ -> type_ t
    E.TyPromoted _ -> mempty
    E.TyEquals t1 t2 -> type_ t1 <> type_ t2
    E.TySplice s -> splice s
    E.TyBang _ t -> type_ t

level :: E.Context -> Levels
level =
  foldMap asst

asst :: E.Asst -> Levels
asst =
  \case
    E.ClassA _ tl -> foldMap type_ tl
    E.VarA _ -> mempty
    E.InfixA t1 _ t2 -> type_ t1 <> type_ t2
    E.IParam _ t -> type_ t
    E.EqualP t1 t2 -> type_ t1 <> type_ t2
    E.ParenA a -> asst a

qName :: Level -> E.QName -> Levels
qName c =
  \case
    E.UnQual n -> name c n
    _ -> mempty

name :: Level -> E.Name -> Levels
name c =
  \case
    E.Ident x | x == marker -> pure c
    E.Symbol x | x == marker -> pure c
    _ -> empty

splice :: E.Splice -> Levels
splice =
  \case
    E.IdSplice _ -> mempty
    E.ParenSplice e -> exp e

exp :: E.Exp -> Levels
exp =
  \case
    E.Var _ -> mempty
    E.IPVar _ -> mempty
    E.Con q -> qName Level_Exp q
    E.Lit _ -> mempty
    E.InfixApp e1 _ e2 -> exp e1 <> exp e2
    E.App e1 e2 -> exp e1 <> exp e2
    E.NegApp e -> exp e
    E.Lambda _ pl e -> foldMap pat pl <> exp e    
    E.Let b e -> binds b <> exp e
    E.If e1 e2 e3 -> exp e1 <> exp e2 <> exp e3
    E.MultiIf gl -> foldMap guardedRhs gl
    E.Case e al -> exp e <> foldMap alt al
    E.Do sl -> foldMap stmt sl
    E.MDo sl -> foldMap stmt sl
    E.Tuple _ el -> foldMap exp el
    E.TupleSection _ em -> (foldMap . foldMap) exp em
    E.List el -> foldMap exp el
    E.ParArray el -> foldMap exp el
    E.Paren e -> exp e
    E.LeftSection e _ -> exp e
    E.RightSection _ e -> exp e
    E.RecConstr {} -> error "Unexpected Haskell98 record construction expression"
    E.RecUpdate {} -> error "Unexpected Haskell98 record update expression"
    E.EnumFrom e -> exp e
    E.EnumFromTo e1 e2 -> exp e1 <> exp e2
    E.EnumFromThen e1 e2 -> exp e1 <> exp e2
    E.EnumFromThenTo e1 e2 e3 -> exp e1 <> exp e2 <> exp e3
    E.ParArrayFromTo e1 e2 -> exp e1 <> exp e2
    E.ParArrayFromThenTo e1 e2 e3 -> exp e1 <> exp e2 <> exp e3
    E.ListComp e stl -> exp e <> foldMap qualStmt stl
    E.ParComp e stll -> exp e <> (foldMap . foldMap) qualStmt stll
    E.ParArrayComp e stll -> exp e <> (foldMap . foldMap) qualStmt stll
    E.ExpTypeSig _ e t -> exp e <> type_ t
    E.VarQuote _ -> mempty
    E.TypQuote _ -> mempty
    E.BracketExp b -> bracket b
    E.SpliceExp s -> splice s
    E.QuasiQuote {} -> mempty
    E.XTag {} -> error "XML is not supported"
    E.XETag {} -> error "XML is not supported"
    E.XPcdata {} -> error "XML is not supported"
    E.XExpTag {} -> error "XML is not supported"
    E.XChildTag {} -> error "XML is not supported"
    E.CorePragma _ e -> exp e
    E.SCCPragma _ e -> exp e
    E.GenPragma _ _ _ e -> exp e
    E.Proc _ p e -> pat p <> exp e
    E.LeftArrApp e1 e2 -> exp e1 <> exp e2
    E.RightArrApp e1 e2 -> exp e1 <> exp e2
    E.LeftArrHighApp e1 e2 -> exp e1 <> exp e2
    E.RightArrHighApp e1 e2 -> exp e1 <> exp e2
    E.LCase al -> foldMap alt al

bracket :: E.Bracket -> Levels
bracket =
  \case
    E.ExpBracket e -> exp e
    E.PatBracket p -> pat p
    E.TypeBracket t -> type_ t
    E.DeclBracket dl -> foldMap decl dl

qualStmt :: E.QualStmt -> Levels
qualStmt =
  \case
    E.QualStmt s -> stmt s
    E.ThenTrans e -> exp e
    E.ThenBy e1 e2 -> exp e1 <> exp e2
    E.GroupBy e -> exp e
    E.GroupUsing e -> exp e
    E.GroupByUsing e1 e2 -> exp e1 <> exp e2

alt :: E.Alt -> Levels
alt =
  \case
    E.Alt _ p r b -> pat p <> rhs r <> binds b

pat :: E.Pat -> Levels
pat =
  \case
    E.PVar _ -> mempty
    E.PLit _ _ -> mempty
    E.PNPlusK _ _ -> mempty
    E.PInfixApp p1 _ p2 -> pat p1 <> pat p2
    E.PApp q pl -> qName Level_Pat q <> foldMap pat pl
    E.PTuple _ pl -> foldMap pat pl
    E.PList pl -> foldMap pat pl
    E.PParen p -> pat p
    E.PRec {} -> error "Unexpected record pattern"
    E.PAsPat _ p -> pat p
    E.PWildCard -> mempty
    E.PIrrPat p -> pat p
    E.PatTypeSig _ p t -> pat p <> type_ t
    E.PViewPat e p -> exp e <> pat p
    E.PRPat rl -> foldMap rPat rl
    E.PXTag {} -> error "XML is not supported"
    E.PXETag {} -> error "XML is not supported"
    E.PXPcdata {} -> error "XML is not supported"
    E.PXPatTag {} -> error "XML is not supported"
    E.PXRPats {} -> error "XML is not supported"
    E.PQuasiQuote _ _ -> mempty
    E.PBangPat p -> pat p

rPat :: E.RPat -> Levels
rPat =
  \case
    E.RPOp r _ -> rPat r
    E.RPEither r1 r2 -> rPat r1 <> rPat r2
    E.RPSeq rl -> foldMap rPat rl
    E.RPGuard p sl -> pat p <> foldMap stmt sl
    E.RPCAs _ r -> rPat r
    E.RPAs _ r -> rPat r
    E.RPParen r -> rPat r
    E.RPPat p -> pat p

stmt :: E.Stmt -> Levels
stmt =
  \case
    E.Generator _ p e -> pat p <> exp e
    E.Qualifier e -> exp e
    E.LetStmt b -> binds b
    E.RecStmt sl -> foldMap stmt sl

binds :: E.Binds -> Levels
binds =
  \case
    E.BDecls dl -> foldMap decl dl
    E.IPBinds il -> foldMap ipBind il

ipBind :: E.IPBind -> Levels
ipBind =
  \case
    E.IPBind _ _ e -> exp e
