-- ------------------------------------------------------------------------
-- -- Declarations                                                       --
-- ------------------------------------------------------------------------

ATTR Declaration Declarations [ | patBindNr : Int | ]
        
SEM MaybeDeclarations [ | |   core : { Core.Expr -> Core.Expr } ]
    | Nothing     lhs.core = \continue -> continue
    | Just        declarations.patBindNr = 0
                  declarations.isTopLevel = False
                  lhs.core = \continue -> letrec_ @declarations.decls continue  

SEM Declaration          
    | Type              lhs.decls  =
        let -- if we would have the collected type synonym information here, things could have been
            -- done much easier.
            (t1,[t2])   = convertFromSimpleTypeAndTypes @simpletype.self [@type.self]
            allTypeVars = ftv [t1,t2]
            (ts1,ts2)   = ( Quantification (allTypeVars, [], [] .=>. t1) :: TpScheme
                          , Quantification (allTypeVars, [], [] .=>. t2) :: TpScheme
                          )
        in
        [ Core.DeclCustom
            { Core.declName    = idFromString (getNameName @simpletype.name)
            , Core.declAccess  = Core.private
            , Core.declKind    = Core.DeclKindCustom (idFromString "typedecl")
            , Core.declCustoms =
                [ Core.CustomBytes
                    (Byte.bytesFromString
                        (  show ts1
                        ++ " = "
                        ++ show ts2
                        )
                    )
                , Core.CustomInt
                    (length @simpletype.typevariables)
                ]
            }
        ]
        ++
        [ DerivingShow.typeShowFunction @self ]
    
    | Data    constructors.tag = 0
              constructors.dataTypeName = @simpletype.name
              lhs.decls  =
        map snd @constructors.cons
        ++
        [ Core.DeclCustom
            { Core.declName    = idFromString (getNameName @simpletype.name)
            , Core.declAccess  = Core.private
            , Core.declKind    = Core.DeclKindCustom (idFromString "data")
            , Core.declCustoms = [Core.CustomInt (length @simpletype.typevariables)]
            }
        ]
        ++
        [ DerivingShow.dataShowFunction @self ]
        ++ 
        (if "Show" `elem` map show @derivings.self 
         then [ DerivingShow.dataDictionary @self ]
         else []
        )
        ++
        (if "Eq" `elem` map show @derivings.self 
         then [ DerivingEq.dataDictionary @self ]
         else []
        )
        
    --  range                    : Range        
    --  context                  : ContextItems
    --  simpletype               : SimpleType
    --  constructors             : Constructors
    --  derivings                : Names
    
    | FunctionBindings  loc.ids      = freshIds "u$" @bindings.arity
                        bindings.ids = @loc.ids
                        bindings.range = @range.self
                        loc.dictionaries = map predicateToId 
                                              (getPredicateForDecl @bindings.name @lhs.dictionaryEnv)
                        lhs.decls    =
        [ Core.DeclValue
            { Core.declName    = idFromName @bindings.name
            , Core.declAccess  = Core.private
            , Core.valueEnc    = Nothing
            , Core.valueValue  = foldr Core.Lam @bindings.core (@dictionaries ++ @ids)
            , Core.declCustoms = toplevelType @bindings.name @lhs.importEnv @lhs.isTopLevel
            }
        ]
    --  range                    : Range          
    --  bindings                 : FunctionBindings -- should all be for the same function
    
    | PatternBinding    lhs.patBindNr = @lhs.patBindNr + 1
                        loc.dictionaries = 
                            case @pattern.self of
                                Pattern_Variable _ n ->
                                   map predicateToId 
                                      (getPredicateForDecl n @lhs.dictionaryEnv)
                                _ -> []                        
                        lhs.decls     =
        case @pattern.self of
            Pattern_Variable _ n ->
                [ Core.DeclValue
                    { Core.declName    = idFromName n
                    , Core.declAccess  = Core.private
                    , Core.valueEnc    = Nothing
                    , Core.valueValue  = 
                        foldr Core.Lam 
                            ( let_ -- because guards can fail
                                nextClauseId (patternMatchFail "pattern binding" @range.self)
                                @righthandside.core
                            )
                            @dictionaries
                    , Core.declCustoms = toplevelType n @lhs.importEnv @lhs.isTopLevel
                    }
               ]
            _ ->
                Core.DeclValue
                    { Core.declName    = patBindId
                    , Core.declAccess  = Core.private
                    , Core.valueEnc    = Nothing
                    , Core.valueValue  = 
                        let_ 
                            nextClauseId (patternMatchFail "pattern binding" @range.self)
                            @righthandside.core
                    , Core.declCustoms = [custom "type" "patternbinding"]
                    }
                :
                [ Core.DeclValue
                    { Core.declName    = idFromName v
                    , Core.declAccess  = Core.private
                    , Core.valueEnc    = Nothing
                    , Core.valueValue  =
                        (let_ nextClauseId (patternMatchFail "pattern binding" @range.self)
                            (patternToCore (patBindId, @pattern.self) (Core.Var (idFromName v)))
                        )
                    , Core.declCustoms = toplevelType v @lhs.importEnv @lhs.isTopLevel
                    }
                | v <- @pattern.vars
                ]
                where 
                    patBindId = idFromString ("patBind$" ++ show @lhs.patBindNr)
    --  range                    : Range
    --  pattern                  : Pattern
    --  righthandside            : RightHandSide
    
    | TypeSignature     lhs.decls    = []
    --  range                    : Range
    --  names                    : Names
    --  type                     : Type   -- may have context
    
    | Fixity            lhs.decls    =
        map
            ( ( \n ->
                Core.DeclCustom
                    { Core.declName    = idFromString n
                    , Core.declAccess  = Core.private
                    , Core.declKind    = (Core.DeclKindCustom . idFromString) "infix"
                    , Core.declCustoms =
                        [ Core.CustomInt 
                             ( case @priority.self of
                                  MaybeInt_Just i  -> i
                                  MaybeInt_Nothing -> 9 )
                        , (Core.CustomBytes . bytesFromString)
                              ( case @fixity.self of
                                   Fixity_Infixr _ -> "right"
                                   Fixity_Infixl _ -> "left"
                                   Fixity_Infix  _ -> "none"
                                   _               -> internalError
                                                        "ToCoreDecl.ag"
                                                        "SEM Declaration.Fixity"
                                                        "unknown fixity"
                              )
                        ]
                    }
              )
              . 
              getNameName
            )
            @operators.self
    --  range                    : Range
    --  fixity                   : Fixity
    --  priority                 : MaybeInt
    --  operators                : Names
    
    -- Not supported
    
    | Newtype           lhs.decls    = internalError "ToCoreDecl" "Declaration" "'newType' not supported"
                        constructor.tag = 0
                        constructor.dataTypeName = @simpletype.name
    --  range                    : Range
    --  context                  : ContextItems
    --  simpletype               : SimpleType
    --  constructor              : Constructor  -- has only one field, no strictness
    --  derivings                : Names
    
    | Class             lhs.decls    = internalError "ToCoreDecl" "Declaration" "'class' not supported"
    --  range                    : Range
    --  context                  : ContextItems -- is a "simple" context
    --  simpletype               : SimpleType   -- Haskell 98 allows only one variable
    --  where                    : MaybeDeclarations -- cannot have everything
    
    | Instance          lhs.decls    = internalError "ToCoreDecl" "Declaration" "'instance' not supported"
    --  range                    : Range
    --  context                  : ContextItems -- is a "simple" context
    --  name                     : Name
    --  types                    : Types        -- Haskell 98 allows only one type
                                                -- that is severely restricted
    --  where                    : MaybeDeclarations -- cannot have everything
    
    | Default           lhs.decls    = internalError "ToCoreDecl" "Declaration" "'default' not supported"
    --  range                    : Range
    --  types                    : Types        -- should be instances of Num
    
    | Empty             lhs.decls    = internalError "ToCoreDecl" "Declaration" "empty declarations not supported"
    --  range                    : Range

ATTR FunctionBinding FunctionBindings 
    [   ids : { [Id] }
    | 
    |   arity : Int
    ]

SEM FunctionBindings [ range : Range | | core : {Core.Expr}  ]
    | Cons             lhs.core  = @hd.core @tl.core
                          .arity = @hd.arity
    | Nil              lhs.core  = patternMatchFail "function bindings" @lhs.range
                          .arity = internalError "ToCoreDecl" "FunctionBindings" "arity: empty list of function bindings"

SEM FunctionBinding [ | | core : { Core.Expr -> Core.Expr } ]
    | FunctionBinding  lhs.arity = @lefthandside.arity
                       lhs.core = 
        \nextClause ->
            let thisClause = 
                    patternsToCore 
                        (zip @lhs.ids @lefthandside.patterns)
                        @righthandside.core in
            if all patternAlwaysSucceeds @lefthandside.patterns 
               &&
               not @righthandside.isGuarded
            then
                thisClause
            else
                let_ nextClauseId nextClause thisClause
                                      
    --  range                    : Range
    --  lefthandside             : LeftHandSide
    --  righthandside            : RightHandSide

{
predicateToId :: Predicate -> Id
predicateToId (Predicate class_ tp) =
    idFromString $ "$dict" ++ class_ ++ show tp
    
dictionaryTreeToCore :: DictionaryTree -> Core.Expr
dictionaryTreeToCore tree = 
   case tree of
      ByPredicate predicate -> 
         Core.Var (predicateToId predicate)
      ByInstance className instanceName trees ->
         foldl Core.Ap
               (Core.Var (idFromString ("$dict"++className++instanceName)))
               (map dictionaryTreeToCore trees)
      BySuperClass subClass superClass tree -> 
         Core.Ap (Core.Var (idFromString ("$get" ++ superClass ++ "From" ++ subClass)))          
                 (dictionaryTreeToCore tree)

insertDictionaries :: Name -> DictionaryEnvironment -> Core.Expr
insertDictionaries name dictionaryEnv = 
   foldl Core.Ap
         (Core.Var (idFromName name))
         (map dictionaryTreeToCore (getDictionaryTrees name dictionaryEnv))
}

ATTR LeftHandSide 
    [ 
    | 
    |   arity : Int
        patterns : Patterns
    ]

SEM LeftHandSide
    | Function         lhs.arity = @patterns.length
                          .patterns = @patterns.self
    --  range                    : Range
    --  name                     : Name
    --  patterns                 : Patterns

    | Infix            lhs.arity = 2
                          .patterns = [@leftPattern.self, @rightPattern.self ]
    --  range                    : Range
    --  leftPattern              : Pattern
    --  operator                 : Name
    --  rightPattern             : Pattern

    | Parenthesized    lhs.arity = @lefthandside.arity + @patterns.length
                          .patterns = @lefthandside.patterns ++ @patterns.self
    --  range                    : Range
    --  lefthandside             : LeftHandSide
    --  patterns                 : Patterns

SEM RightHandSide
    [ 
    | 
    |   core : { Core.Expr } 
        isGuarded : Bool
    ]

    | Expression      lhs.core = @where.core @expression.core
                         .isGuarded = False
    --  range                    : Range
    --  expression               : Expression
    --  where                    : MaybeDeclarations

    | Guarded         lhs.isGuarded = True
                         .core = 
        @where.core (foldr ($) (Core.Var nextClauseId) @guardedexpressions.core)
                         
    --  range                    : Range
    --  guardedexpressions       : GuardedExpressions
    --  where                    : MaybeDeclarations

-- ------------------------------------------------------------------------
-- -- Types                                                              --
-- ------------------------------------------------------------------------

ATTR Constructors Constructor 
    [   tag : Int 
    | 
    |   cons USE { ++ } { [] } : { [(Id, CoreDecl)] } 
    ]

SEM Constructors [ dataTypeName : Name | | ]
    | Cons  hd.tag = @lhs.tag
            tl.tag = @lhs.tag + 1

SEM Constructor [ dataTypeName : Name | | ]
    | Constructor       lhs.cons = 
        [ (idFromName @constructor.self, Core.DeclCon
            { Core.declName    = idFromName @constructor.self
            , Core.declAccess  = Core.private
            , Core.declArity   = @types.length
            , Core.conTag      = @lhs.tag
            , Core.declCustoms = constructorCustoms 
                                    @lhs.dataTypeName
                                    @constructor.self 
                                    (valueConstructors @lhs.importEnv)
            }
          )
        ]
    --  range                    : Range
    --  constructor              : Name
    --  types                    : AnnotatedTypes
    
    | Infix             lhs.cons = 
        [ (idFromName @constructorOperator.self, Core.DeclCon
            { Core.declName    = idFromName @constructorOperator.self
            , Core.declAccess  = Core.private
            , Core.declArity   = 2
            , Core.conTag      = @lhs.tag
            , Core.declCustoms = constructorCustoms
                                    @lhs.dataTypeName
                                    @constructorOperator.self 
                                    (valueConstructors @lhs.importEnv)
            }
          )
        ]
    --  range                    : Range
    --  leftType                 : AnnotatedType
    --  constructorOperator      : Name
    --  rightType                : AnnotatedType
    
-- Not supported

    | Record            lhs.cons = internalError "ToCoreDecl" "Constructor" "records not supported"
    --  range                    : Range
    --  constructor              : Name
    --  fieldDeclarations        : FieldDeclarations

SEM AnnotatedTypes [ | | length : Int ]
    | Cons lhs.length = 1 + @tl.length
    | Nil  lhs.length = 0

{
toplevelType :: Name -> ImportEnvironment -> Bool -> [Core.Custom]
toplevelType name ie isTopLevel
    | isTopLevel = [custom "type" typeString]
    | otherwise  = []
    where
        typeString = maybe
            (internalError "ToCoreDecl" "Declaration" ("no type found for " ++ getNameName name))
            show
            (M.lookup name (typeEnvironment ie))

constructorCustoms :: Name -> Name -> ValueConstructorEnvironment -> [Core.Custom]
constructorCustoms dataTypeName name env =
    maybe 
        (internalError "ToCoreDecl" "Constructor" ("no type found for " ++ show name))
        (\tpScheme -> 
            [ custom "type" (show tpScheme)
            , Core.CustomLink 
                    (idFromName dataTypeName) 
                    (Core.DeclKindCustom (idFromString "data"))
            ]
        )
        (M.lookup name env)
}
