{- |
    Module      :  $Header$
    Description :  Abstract syntax for Curry
    Copyright   :  (c) 1999 - 2004 Wolfgang Lux
                       2005        Martin Engelke
                       2011 - 2015 Björn Peemöller
                       2014        Jan Rasmus Tikovsky
                       2016        Finn Teegen
    License     :  BSD-3-clause

    Maintainer  :  bjp@informatik.uni-kiel.de
    Stability   :  experimental
    Portability :  portable

    This module provides the necessary data structures to maintain the
    parsed representation of a Curry program.
-}

module Curry.Syntax.Type
  ( -- * Module header
    Module (..)
    -- ** Module pragmas
  , ModulePragma (..), Extension (..), KnownExtension (..), Tool (..)
    -- ** Export specification
  , ExportSpec (..), Export (..)
    -- ** Import declarations
  , ImportDecl (..), ImportSpec (..), Import (..), Qualified
    -- * Interface
  , Interface (..), IImportDecl (..), Arity, IDecl (..), KindExpr (..)
  , IMethodDecl (..), IMethodImpl
    -- * Declarations
  , Decl (..), Precedence, Infix (..), ConstrDecl (..), NewConstrDecl (..)
  , FieldDecl (..)
  , CallConv (..), TypeExpr (..), QualTypeExpr (..)
  , Equation (..), Lhs (..), Rhs (..), CondExpr (..)
  , Literal (..), Pattern (..), Expression (..), InfixOp (..)
  , Statement (..), CaseType (..), Alt (..), Field (..), Var (..)
    -- * Type classes
  , Context, Constraint (..), InstanceType
    -- * Goals
  , Goal (..)
  ) where

import Curry.Base.Ident
import Curry.Base.Position
import Curry.Base.Pretty      (Pretty(..))

import Curry.Syntax.Extension

import Text.PrettyPrint

-- ---------------------------------------------------------------------------
-- Modules
-- ---------------------------------------------------------------------------

-- |Curry module
data Module a = Module [ModulePragma] ModuleIdent (Maybe ExportSpec)
                       [ImportDecl] [Decl a]
    deriving (Eq, Read, Show)

-- |Module pragma
data ModulePragma
  = LanguagePragma Position [Extension]         -- ^ language pragma
  | OptionsPragma  Position (Maybe Tool) String -- ^ options pragma
    deriving (Eq, Read, Show)

-- |Export specification
data ExportSpec = Exporting Position [Export]
    deriving (Eq, Read, Show)

-- |Single exported entity
data Export
  = Export         QualIdent         -- f/T
  | ExportTypeWith QualIdent [Ident] -- T (C1,...,Cn)
  | ExportTypeAll  QualIdent         -- T (..)
  | ExportModule   ModuleIdent       -- module M
    deriving (Eq, Read, Show)

-- |Import declaration
data ImportDecl = ImportDecl Position ModuleIdent Qualified
                             (Maybe ModuleIdent) (Maybe ImportSpec)
    deriving (Eq, Read, Show)

-- |Flag to signal qualified import
type Qualified = Bool

-- |Import specification
data ImportSpec
  = Importing Position [Import]
  | Hiding    Position [Import]
    deriving (Eq, Read, Show)

-- |Single imported entity
data Import
  = Import         Ident            -- f/T
  | ImportTypeWith Ident [Ident]    -- T (C1,...,Cn)
  | ImportTypeAll  Ident            -- T (..)
    deriving (Eq, Read, Show)

-- ---------------------------------------------------------------------------
-- Module interfaces
-- ---------------------------------------------------------------------------

-- | Module interface
--
-- Interface declarations are restricted to type declarations and signatures.
-- Note that an interface function declaration additionaly contains the
-- function arity (= number of parameters) in order to generate
-- correct FlatCurry function applications.
data Interface = Interface ModuleIdent [IImportDecl] [IDecl]
    deriving (Eq, Read, Show)

-- |Interface import declaration
data IImportDecl = IImportDecl Position ModuleIdent
    deriving (Eq, Read, Show)

-- |Arity of a function
type Arity = Int

-- |Interface declaration
data IDecl
  = IInfixDecl      Position Infix Precedence QualIdent
  | HidingDataDecl  Position QualIdent (Maybe KindExpr) [Ident]
  | IDataDecl       Position QualIdent (Maybe KindExpr) [Ident] [ConstrDecl]  [Ident]
  | INewtypeDecl    Position QualIdent (Maybe KindExpr) [Ident] NewConstrDecl [Ident]
  | ITypeDecl       Position QualIdent (Maybe KindExpr) [Ident] TypeExpr
  | IFunctionDecl   Position QualIdent (Maybe Ident) Arity QualTypeExpr
  | HidingClassDecl Position Context QualIdent (Maybe KindExpr) Ident
  | IClassDecl      Position Context QualIdent (Maybe KindExpr) Ident [IMethodDecl] [Ident]
  | IInstanceDecl   Position Context QualIdent InstanceType [IMethodImpl] (Maybe ModuleIdent)
    deriving (Eq, Read, Show)

-- |Class methods
data IMethodDecl = IMethodDecl Position Ident (Maybe Arity) QualTypeExpr
  deriving (Eq, Read, Show)

-- |Class method implementations
type IMethodImpl = (Ident, Arity)

-- |Kind expressions
data KindExpr
  = Star
  | ArrowKind KindExpr KindExpr
    deriving (Eq, Read, Show)

-- ---------------------------------------------------------------------------
-- Declarations (local or top-level)
-- ---------------------------------------------------------------------------

-- |Declaration in a module
data Decl a
  = InfixDecl        Position Infix (Maybe Precedence) [Ident]         -- infixl 5 (op), `fun`
  | DataDecl         Position Ident [Ident] [ConstrDecl] [QualIdent]   -- data C a b = C1 a | C2 b deriving (D, ...)
  | ExternalDataDecl Position Ident [Ident]
  | NewtypeDecl      Position Ident [Ident] NewConstrDecl [QualIdent]  -- newtype C a b = C a b deriving (D, ...)
  | TypeDecl         Position Ident [Ident] TypeExpr                   -- type C a b = D a b
  | TypeSig          Position [Ident] QualTypeExpr                     -- f, g :: Bool
  | FunctionDecl     Position a Ident [Equation a]                     -- f True = 1 ; f False = 0
  | ExternalDecl     Position [Var a]                                  -- f, g external
  | PatternDecl      Position (Pattern a) (Rhs a)                      -- Just x = ...
  | FreeDecl         Position [Var a]                                  -- x, y free
  | DefaultDecl      Position [TypeExpr]                               -- default (Int, Float)
  | ClassDecl        Position Context Ident Ident [Decl a]             -- class C a => D a where {TypeSig|InfixDecl|FunctionDecl}
  | InstanceDecl     Position Context QualIdent InstanceType [Decl a]  -- instance C a => M.D (N.T a b c) where {FunctionDecl}
    deriving (Eq, Read, Show)

-- ---------------------------------------------------------------------------
-- Infix declaration
-- ---------------------------------------------------------------------------

-- |Operator precedence
type Precedence = Integer

-- |Fixity of operators
data Infix
  = InfixL -- ^ left-associative
  | InfixR -- ^ right-associative
  | Infix  -- ^ no associativity
    deriving (Eq, Read, Show)

-- |Constructor declaration for algebraic data types
data ConstrDecl
  = ConstrDecl Position [Ident] Context Ident [TypeExpr]
  | ConOpDecl  Position [Ident] Context TypeExpr Ident TypeExpr
  | RecordDecl Position [Ident] Context Ident [FieldDecl]
    deriving (Eq, Read, Show)

-- |Constructor declaration for renaming types (newtypes)
data NewConstrDecl
  = NewConstrDecl Position Ident TypeExpr
  | NewRecordDecl Position Ident (Ident, TypeExpr)
   deriving (Eq, Read, Show)

-- |Declaration for labelled fields
data FieldDecl = FieldDecl Position [Ident] TypeExpr
  deriving (Eq, Read, Show)

-- |Calling convention for C code
data CallConv
  = CallConvPrimitive
  | CallConvCCall
    deriving (Eq, Read, Show)

-- |Type expressions
data TypeExpr
  = ConstructorType QualIdent
  | ApplyType       TypeExpr TypeExpr
  | VariableType    Ident
  | TupleType       [TypeExpr]
  | ListType        TypeExpr
  | ArrowType       TypeExpr TypeExpr
  | ParenType       TypeExpr
  | ForallType      [Ident] TypeExpr
    deriving (Eq, Read, Show)

-- |Qualified type expressions
data QualTypeExpr = QualTypeExpr Context TypeExpr
    deriving (Eq, Read, Show)

-- ---------------------------------------------------------------------------
-- Type classes
-- ---------------------------------------------------------------------------

type Context = [Constraint]

data Constraint = Constraint QualIdent TypeExpr
    deriving (Eq, Read, Show)

type InstanceType = TypeExpr

-- ---------------------------------------------------------------------------
-- Functions
-- ---------------------------------------------------------------------------

-- |Function defining equation
data Equation a = Equation Position (Lhs a) (Rhs a)
    deriving (Eq, Read, Show)

-- |Left-hand-side of an 'Equation' (function identifier and patterns)
data Lhs a
  = FunLhs Ident [Pattern a]             -- f x y
  | OpLhs  (Pattern a) Ident (Pattern a) -- x $ y
  | ApLhs  (Lhs a) [Pattern a]           -- ($) x y
    deriving (Eq, Read, Show)

-- |Right-hand-side of an 'Equation'
data Rhs a
  = SimpleRhs  Position (Expression a) [Decl a] -- @expr where decls@
  | GuardedRhs [CondExpr a] [Decl a]            -- @| cond = expr where decls@
    deriving (Eq, Read, Show)

-- |Conditional expression (expression conditioned by a guard)
data CondExpr a = CondExpr Position (Expression a) (Expression a)
    deriving (Eq, Read, Show)

-- |Literal
data Literal
  = Char   Char
  | Int    Integer
  | Float  Double
  | String String
    deriving (Eq, Read, Show)

-- |Constructor term (used for patterns)
data Pattern a
  = LiteralPattern     a Literal
  | NegativePattern    a Literal
  | VariablePattern    a Ident
  | ConstructorPattern a QualIdent [Pattern a]
  | InfixPattern       a (Pattern a) QualIdent (Pattern a)
  | ParenPattern       (Pattern a)
  | RecordPattern      a QualIdent [Field (Pattern a)] -- C { l1 = p1, ..., ln = pn }
  | TuplePattern       [Pattern a]
  | ListPattern        a [Pattern a]
  | AsPattern          Ident (Pattern a)
  | LazyPattern        (Pattern a)
  | FunctionPattern    a QualIdent [Pattern a]
  | InfixFuncPattern   a (Pattern a) QualIdent (Pattern a)
    deriving (Eq, Read, Show)

-- |Expression
data Expression a
  = Literal           a Literal
  | Variable          a QualIdent
  | Constructor       a QualIdent
  | Paren             (Expression a)
  | Typed             (Expression a) QualTypeExpr
  | Record            a QualIdent [Field (Expression a)]    -- C {l1 = e1,..., ln = en}
  | RecordUpdate      (Expression a) [Field (Expression a)] -- e {l1 = e1,..., ln = en}
  | Tuple             [Expression a]
  | List              a [Expression a]
  | ListCompr         (Expression a) [Statement a]   -- the ref corresponds to the main list
  | EnumFrom          (Expression a)
  | EnumFromThen      (Expression a) (Expression a)
  | EnumFromTo        (Expression a) (Expression a)
  | EnumFromThenTo    (Expression a) (Expression a) (Expression a)
  | UnaryMinus        (Expression a)
  | Apply             (Expression a) (Expression a)
  | InfixApply        (Expression a) (InfixOp a) (Expression a)
  | LeftSection       (Expression a) (InfixOp a)
  | RightSection      (InfixOp a) (Expression a)
  | Lambda            [Pattern a] (Expression a)
  | Let               [Decl a] (Expression a)
  | Do                [Statement a] (Expression a)
  | IfThenElse        (Expression a) (Expression a) (Expression a)
  | Case              CaseType (Expression a) [Alt a]
    deriving (Eq, Read, Show)

-- |Infix operation
data InfixOp a
  = InfixOp     a QualIdent
  | InfixConstr a QualIdent
    deriving (Eq, Read, Show)

-- |Statement (used for do-sequence and list comprehensions)
data Statement a
  = StmtExpr (Expression a)
  | StmtDecl [Decl a]
  | StmtBind (Pattern a) (Expression a)
    deriving (Eq, Read, Show)

-- |Type of case expressions
data CaseType
  = Rigid
  | Flex
    deriving (Eq, Read, Show)

-- |Single case alternative
data Alt a = Alt Position (Pattern a) (Rhs a)
    deriving (Eq, Read, Show)

-- |Record field
data Field a = Field Position QualIdent a
    deriving (Eq, Read, Show)

-- |Annotated identifier
data Var a = Var a Ident
    deriving (Eq, Read, Show)

-- ---------------------------------------------------------------------------
-- Goals
-- ---------------------------------------------------------------------------

-- |Goal in REPL (expression to evaluate)
data Goal a = Goal Position (Expression a) [Decl a]
    deriving (Eq, Read, Show)

-- ---------------------------------------------------------------------------
-- instances
-- ---------------------------------------------------------------------------

instance Functor Module where
  fmap f (Module ps m es is ds) = Module ps m es is (map (fmap f) ds)

instance Functor Decl where
  fmap _ (InfixDecl p fix prec ops) = InfixDecl p fix prec ops
  fmap _ (DataDecl p tc tvs cs clss) = DataDecl p tc tvs cs clss
  fmap _ (ExternalDataDecl p tc tvs) = ExternalDataDecl p tc tvs
  fmap _ (NewtypeDecl p tc tvs nc clss) = NewtypeDecl p tc tvs nc clss
  fmap _ (TypeDecl p tc tvs ty) = TypeDecl p tc tvs ty
  fmap _ (TypeSig p fs qty) = TypeSig p fs qty
  fmap f (FunctionDecl p a f' eqs) = FunctionDecl p (f a) f' (map (fmap f) eqs)
  fmap f (ExternalDecl p vs) = ExternalDecl p (map (fmap f) vs)
  fmap f (PatternDecl p t rhs) = PatternDecl p (fmap f t) (fmap f rhs)
  fmap f (FreeDecl p vs) = FreeDecl p (map (fmap f) vs)
  fmap _ (DefaultDecl p tys) = DefaultDecl p tys
  fmap f (ClassDecl p cx cls clsvar ds) =
    ClassDecl p cx cls clsvar (map (fmap f) ds)
  fmap f (InstanceDecl p cx qcls inst ds) =
    InstanceDecl p cx qcls inst (map (fmap f) ds)

instance Functor Equation where
  fmap f (Equation p lhs rhs) = Equation p (fmap f lhs) (fmap f rhs)

instance Functor Lhs where
  fmap f (FunLhs f' ts) = FunLhs f' (map (fmap f) ts)
  fmap f (OpLhs t1 op t2) = OpLhs (fmap f t1) op (fmap f t2)
  fmap f (ApLhs lhs ts) = ApLhs (fmap f lhs) (map (fmap f) ts)

instance Functor Rhs where
  fmap f (SimpleRhs p e ds) = SimpleRhs p (fmap f e) (map (fmap f) ds)
  fmap f (GuardedRhs cs ds) = GuardedRhs (map (fmap f) cs) (map (fmap f) ds)

instance Functor CondExpr where
  fmap f (CondExpr p g e) = CondExpr p (fmap f g) (fmap f e)

instance Functor Pattern where
  fmap f (LiteralPattern a l) = LiteralPattern (f a) l
  fmap f (NegativePattern a l) = NegativePattern (f a) l
  fmap f (VariablePattern a v) = VariablePattern (f a) v
  fmap f (ConstructorPattern a c ts) =
    ConstructorPattern (f a) c (map (fmap f) ts)
  fmap f (InfixPattern a t1 op t2) =
    InfixPattern (f a) (fmap f t1) op (fmap f t2)
  fmap f (ParenPattern t) = ParenPattern (fmap f t)
  fmap f (RecordPattern a c fs) =
    RecordPattern (f a) c (map (fmap (fmap f)) fs)
  fmap f (TuplePattern ts) = TuplePattern (map (fmap f) ts)
  fmap f (ListPattern a ts) = ListPattern (f a) (map (fmap f) ts)
  fmap f (AsPattern v t) = AsPattern v (fmap f t)
  fmap f (LazyPattern t) = LazyPattern (fmap f t)
  fmap f (FunctionPattern a f' ts) =
    FunctionPattern (f a) f' (map (fmap f) ts)
  fmap f (InfixFuncPattern a t1 op t2) =
    InfixFuncPattern (f a) (fmap f t1) op (fmap f t2)

instance Functor Expression where
  fmap f (Literal a l) = Literal (f a) l
  fmap f (Variable a v) = Variable (f a) v
  fmap f (Constructor a c) = Constructor (f a) c
  fmap f (Paren e) = Paren (fmap f e)
  fmap f (Typed e qty) = Typed (fmap f e) qty
  fmap f (Record a c fs) = Record (f a) c (map (fmap (fmap f)) fs)
  fmap f (RecordUpdate e fs) = RecordUpdate (fmap f e) (map (fmap (fmap f)) fs)
  fmap f (Tuple es) = Tuple (map (fmap f) es)
  fmap f (List a es) = List (f a) (map (fmap f) es)
  fmap f (ListCompr e stms) = ListCompr (fmap f e) (map (fmap f) stms)
  fmap f (EnumFrom e) = EnumFrom (fmap f e)
  fmap f (EnumFromThen e1 e2) = EnumFromThen (fmap f e1) (fmap f e2)
  fmap f (EnumFromTo e1 e2) = EnumFromTo (fmap f e1) (fmap f e2)
  fmap f (EnumFromThenTo e1 e2 e3) =
    EnumFromThenTo (fmap f e1) (fmap f e2) (fmap f e3)
  fmap f (UnaryMinus e) = UnaryMinus (fmap f e)
  fmap f (Apply e1 e2) = Apply (fmap f e1) (fmap f e2)
  fmap f (InfixApply e1 op e2) =
    InfixApply (fmap f e1) (fmap f op) (fmap f e2)
  fmap f (LeftSection e op) = LeftSection (fmap f e) (fmap f op)
  fmap f (RightSection op e) = RightSection (fmap f op) (fmap f e)
  fmap f (Lambda ts e) = Lambda (map (fmap f) ts) (fmap f e)
  fmap f (Let ds e) = Let (map (fmap f) ds) (fmap f e)
  fmap f (Do stms e) = Do (map (fmap f) stms) (fmap f e)
  fmap f (IfThenElse e1 e2 e3) =
    IfThenElse (fmap f e1) (fmap f e2) (fmap f e3)
  fmap f (Case ct e as) = Case ct (fmap f e) (map (fmap f) as)

instance Functor InfixOp where
  fmap f (InfixOp a op) = InfixOp (f a) op
  fmap f (InfixConstr a op) = InfixConstr (f a) op

instance Functor Statement where
  fmap f (StmtExpr e) = StmtExpr (fmap f e)
  fmap f (StmtDecl ds) = StmtDecl (map (fmap f) ds)
  fmap f (StmtBind t e) = StmtBind (fmap f t) (fmap f e)

instance Functor Alt where
  fmap f (Alt p t rhs) = Alt p (fmap f t) (fmap f rhs)

instance Functor Field where
  fmap f (Field p l x) = Field p l (f x)

instance Functor Var where
  fmap f (Var a v) = Var (f a) v

instance Functor Goal where
  fmap f (Goal p e ds) = Goal p (fmap f e) (map (fmap f) ds)

instance Pretty Infix where
  pPrint InfixL = text "infixl"
  pPrint InfixR = text "infixr"
  pPrint Infix  = text "infix"