Types.hs

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}

-- | All the types used for parsing, and helpers working on these types.
module Puppet.Parser.Types
  ( -- ** Expressions
    Expression (..),
    SelectorCase (..),
    UnresolvedValue (..),
    LambdaFunc (..),
    HOLambdaCall (..),
    ChainableRes (..),
    HasHOLambdaCall (..),
    LambdaParameter (..),
    LambdaParameters,
    CompRegex (..),
    CollectorType (..),
    Virtuality (..),
    NodeDesc (..),
    LinkType (..),

    -- ** Synonyms
    Parser,
    PuppetParseError,

    -- ** Datatypes
    UDataType (..),

    -- ** Search Expressions
    SearchExpression (..),

    -- ** Declaration
    AttributeDecl (..),
    ArrowOp (..),
    ConditionalDecl (..),
    ClassDecl (..),
    ResDefaultDecl (..),
    DepDecl (..),
    Statement (..),
    ResDecl (..),
    ResOverrideDecl (..),
    DefineDecl (..),
    NodeDecl (..),
    VarAssignDecl (..),
    MainFuncDecl (..),
    HigherOrderLambdaDecl (..),
    ResCollDecl (..),
    Parameters,
  )
where

import qualified Data.Maybe.Strict as S
import qualified Data.Text as Text
import qualified Data.Vector as V
import qualified GHC.Exts as Exts
import Puppet.Language
import Text.Megaparsec
import XPrelude hiding (show)

type PuppetParseError = ParseError Char Void

type Parser = Parsec Void Text

-- | /High Order lambdas/.
newtype LambdaFunc = LambdaFunc Text deriving (Eq, Show)

-- | Lambda block parameters:
type LambdaParameters = Vector LambdaParameter

data LambdaParameter
  = LambdaParam !(Maybe UDataType) !Text
  deriving (Eq, Show)

-- The description of the /higher level lambda/ call.
data HOLambdaCall = HOLambdaCall
  { _hoLambdaFunc :: !LambdaFunc,
    _hoLambdaExpr :: !(Vector Expression),
    _hoLambdaParams :: !LambdaParameters,
    _hoLambdaStatements :: !(Vector Statement),
    _hoLambdaLastExpr :: !(S.Maybe Expression)
  }
  deriving (Eq, Show)

data ChainableRes
  = ChainResColl !ResCollDecl
  | ChainResDecl !ResDecl
  | ChainResRefr !Text [Expression] !PPosition
  deriving (Show, Eq)

data AttributeDecl
  = AttributeDecl !Text !ArrowOp !Expression
  | AttributeWildcard !Expression
  deriving (Show, Eq)

data ArrowOp
  = -- | `+>`
    AppendArrow
  | -- | `=>`
    AssignArrow
  deriving (Show, Eq)

-- | An unresolved value, typically the parser's output.
data UnresolvedValue
  = -- | Special tokens generated when parsing the @true@ or @false@ literals.
    UBoolean !Bool
  | -- | Raw string.
    UString !Text
  | -- | A string that might contain variable references. The type should be refined at one point.
    UInterpolable !(Vector Expression)
  | -- | Special token that is generated when parsing the @undef@ literal.
    UUndef
  | -- | Alike @Resource[reference]@
    UResourceReference !Text !Expression
  | UArray !(Vector Expression)
  | UHash !(Vector (Pair Expression Expression))
  | -- | The regular expression compilation is performed during parsing.
    URegexp !CompRegex
  | UVariableReference !Text
  | UFunctionCall !Text !(Vector Expression)
  | UHOLambdaCall !HOLambdaCall
  | UNumber !Scientific
  | UDataType UDataType
  deriving (Show, Eq)

instance Exts.IsList UnresolvedValue where
  type Item UnresolvedValue = Expression
  fromList = UArray . V.fromList
  toList u = case u of
    UArray lst -> V.toList lst
    _ -> [Terminal u]

instance IsString UnresolvedValue where
  fromString = UString . Text.pack

data SelectorCase
  = SelectorValue !UnresolvedValue
  | SelectorType !UDataType
  | SelectorDefault
  deriving (Eq, Show)

-- | The 'Expression's
data Expression
  = Equal !Expression !Expression
  | Different !Expression !Expression
  | Not !Expression
  | And !Expression !Expression
  | Or !Expression !Expression
  | LessThan !Expression !Expression
  | MoreThan !Expression !Expression
  | LessEqualThan !Expression !Expression
  | MoreEqualThan !Expression !Expression
  | RegexMatch !Expression !Expression
  | NotRegexMatch !Expression !Expression
  | Contains !Expression !Expression
  | Addition !Expression !Expression
  | Substraction !Expression !Expression
  | Division !Expression !Expression
  | Multiplication !Expression !Expression
  | Modulo !Expression !Expression
  | RightShift !Expression !Expression
  | LeftShift !Expression !Expression
  | -- | Hash lookup @$var[\'key0\'][\'key1\']@
    Lookup !Expression !Expression
  | Negate !Expression
  | -- | All conditionals are stored in this format.
    ConditionalValue !Expression !(Vector (Pair SelectorCase Expression))
  | -- | This is for /higher order functions/.
    FunctionApplication !Expression !Expression
  | -- | Terminal object contains no expression
    Terminal !UnresolvedValue
  deriving (Eq, Show)

data UDataType
  = UDTType
  | UDTString (Maybe Int) (Maybe Int)
  | UDTInteger (Maybe Int) (Maybe Int)
  | UDTFloat (Maybe Double) (Maybe Double)
  | UDTBoolean
  | UDTArray UDataType Int (Maybe Int)
  | UDTHash UDataType UDataType Int (Maybe Int)
  | UDTUndef
  | UDTScalar
  | UDTData
  | UDTOptional UDataType
  | UNotUndef
  | UDTVariant (NonEmpty UDataType)
  | UDTPattern (NonEmpty CompRegex)
  | UDTEnum (NonEmpty Expression)
  | UDTAny
  | UDTCollection
  | UDTRegexp (Maybe CompRegex)
  | UDTDeferred
  | UDTSensitive UDataType
  -- Tuple (NonEmpty DataType) Integer Integer
  -- DTDefault
  -- Struct TODO
  deriving (Eq, Show)

instance Exts.IsList Expression where
  type Item Expression = Expression
  fromList = Terminal . Exts.fromList
  toList u = case u of
    Terminal t -> Exts.toList t
    _ -> [u]

instance Num Expression where
  (+) = Addition
  (-) = Substraction
  (*) = Multiplication
  fromInteger = Terminal . UNumber . fromInteger
  abs x = ConditionalValue (MoreEqualThan x 0) (V.fromList [SelectorValue (UBoolean True) :!: x, SelectorDefault :!: negate x])
  signum x =
    ConditionalValue
      (MoreThan x 0)
      ( V.fromList
          [ SelectorValue (UBoolean True) :!: 1,
            SelectorDefault
              :!: ConditionalValue (Equal x 0) (V.fromList [SelectorValue (UBoolean True) :!: 0, SelectorDefault :!: (-1)])
          ]
      )

instance Fractional Expression where
  (/) = Division
  recip x = 1 / x
  fromRational = Terminal . UNumber . fromRational

instance IsString Expression where
  fromString = Terminal . fromString

-- | Search expression inside collector @ \<| searchexpr |> @
data SearchExpression
  = EqualitySearch !Text !Expression
  | NonEqualitySearch !Text !Expression
  | AndSearch !SearchExpression !SearchExpression
  | OrSearch !SearchExpression !SearchExpression
  | AlwaysTrue
  deriving (Eq, Show)

data CollectorType
  = -- | Single angle brackets @\<|   |>@
    Collector
  | -- | Double angle brackets @\<\<|   |>>@
    ExportedCollector
  deriving (Eq, Show)

data NodeDesc
  = NodeName !Text
  | NodeMatch !CompRegex
  | NodeDefault
  deriving (Show, Eq)

-- | Resource declaration:
--
-- @ file { mode => 755} @
data ResDecl = ResDecl !Text !Expression !(Vector AttributeDecl) !Virtuality !PPosition deriving (Eq, Show)

-- | Resource default:
--
-- @ File { mode => 755 } @
--
-- <https://docs.puppetlabs.com/puppet/latest/reference/lang_defaults.html#language:-resource-default-statements puppet reference>.
data ResDefaultDecl = ResDefaultDecl !Text !(Vector AttributeDecl) !PPosition deriving (Eq, Show)

-- | Resource override:
--
-- @ File['title'] { mode => 755} @
--
-- See <https://docs.puppetlabs.com/puppet/latest/reference/lang_resources_advanced.html#amending-attributes-with-a-resource-reference puppet reference>.
data ResOverrideDecl = ResOverrideDecl !Text !Expression !(Vector AttributeDecl) !PPosition deriving (Eq, Show)

-- | All types of conditional statements : @case@, @if@, ...
--
-- Stored as an ordered list of pair @ (condition, statements) @.
-- Interpreted as "if first cond is true, choose first statements, else take the next pair, check the condition ..."
data ConditionalDecl = ConditionalDecl !(Vector (Pair Expression (Vector Statement))) !PPosition deriving (Eq, Show)

-- | Declare a class with
--
-- * a name
-- * a list of parameters
-- * an optional inherits
-- * a list of statements
-- * a position
data ClassDecl = ClassDecl !Text !Parameters !(S.Maybe Text) !(Vector Statement) !PPosition deriving (Eq, Show)

-- | Declare a define with
-- * a name
-- * a list of parameters
-- * a list of statements
-- * a position
data DefineDecl = DefineDecl !Text !Parameters !(Vector Statement) !PPosition deriving (Eq, Show)

type Parameters = Vector (Pair (Pair Text (S.Maybe UDataType)) (S.Maybe Expression))

-- | A node is a collection of statements + maybe an inherit node.
data NodeDecl = NodeDecl !NodeDesc !(Vector Statement) !(S.Maybe NodeDesc) !PPosition deriving (Eq, Show)

-- | @ $newvar = 'world' @
data VarAssignDecl = VarAssignDecl
  { _vadtype :: Maybe UDataType,
    _vadnames :: [Text],
    _vadvalue :: !Expression,
    _vadpos :: !PPosition
  }
  deriving (Eq, Show)

data MainFuncDecl = MainFuncDecl !Text !(Vector Expression) !PPosition deriving (Eq, Show)

-- | /Higher order function/ call.
data HigherOrderLambdaDecl = HigherOrderLambdaDecl !HOLambdaCall !PPosition deriving (Eq, Show)

-- | Resource Collector including exported collector (`\<\<| |>>`)
--
-- @ User \<| title == 'jenkins' |> { groups +> "docker"} @
--
-- See <https://docs.puppetlabs.com/puppet/latest/reference/lang_collectors.html#language:-resource-collectors puppet reference>
data ResCollDecl = ResCollDecl !CollectorType !Text !SearchExpression !(Vector AttributeDecl) !PPosition deriving (Eq, Show)

data DepDecl = DepDecl !(Pair Text Expression) !(Pair Text Expression) !LinkType !PPosition deriving (Eq, Show)

-- | All possible statements.
data Statement
  = ResourceDeclaration !ResDecl
  | ResourceDefaultDeclaration !ResDefaultDecl
  | ResourceOverrideDeclaration !ResOverrideDecl
  | ResourceCollectionDeclaration !ResCollDecl
  | ClassDeclaration !ClassDecl
  | DefineDeclaration !DefineDecl
  | NodeDeclaration !NodeDecl
  | ConditionalDeclaration !ConditionalDecl
  | VarAssignmentDeclaration !VarAssignDecl
  | MainFunctionDeclaration !MainFuncDecl
  | HigherOrderLambdaDeclaration !HigherOrderLambdaDecl
  | DependencyDeclaration !DepDecl
  | -- | Special statement used to include the expressions that are top level. Certainly buggy, but probably just like the original implementation.
    TopContainer !(Vector Statement) !Statement
  deriving (Eq, Show)

makeClassy ''HOLambdaCall