{-# LANGUAGE FlexibleContexts, TemplateHaskell #-}
module Puppet.Lens
( -- * Pure resolution prisms
_PResolveExpression
, _PResolveValue
-- * Prisms for PValues (reexport from "Puppet.Interpreter.Types")
, _PHash
, _PBoolean
, _PString
, _PNumber
, _PResourceReference
, _PUndef
, _PArray
-- * Lenses and prims for 'Statement's
, _Statements
, _ResDecl
, _ResDefaultDecl
, _ResOverrDecl
, _ResCollDecl
, _ConditionalDecl
, _ClassDecl
, _DefineDecl
, _NodeDecl
, _VarAssignDecl
, _MainFuncDecl
, _HigherOrderLambdaDecl
, _DepDecl
-- * Prim for 'Expression's
, _Equal
, _Different
, _Not
, _And
, _Or
, _LessThan
, _MoreThan
, _LessEqualThan
, _MoreEqualThan
, _RegexMatch
, _NotRegexMatch
, _Contains
, _Addition
, _Substraction
, _Division
, _Multiplication
, _Modulo
, _RightShift
, _LeftShift
, _Lookup
, _Negate
, _ConditionalValue
, _FunctionApplication
, _Terminal
-- * Prisms for exceptions
, _PrettyError
) where
import Control.Lens
import Puppet.Parser (puppetParser)
import Puppet.Parser.Types
import Puppet.Interpreter.Types
import Puppet.Interpreter.Pure
import Puppet.Interpreter.Resolve
import qualified Puppet.Parser.PrettyPrinter()
import qualified Data.Vector as V
import qualified Data.HashMap.Strict as HM
import Data.Tuple.Strict hiding (uncurry)
import Control.Exception (SomeException, toException, fromException)
import qualified Data.Text as T
import Text.PrettyPrint.ANSI.Leijen (pretty)
import Text.Megaparsec (parse)
makePrisms ''Expression
_PuppetParser :: Prism' T.Text (V.Vector Statement)
_PuppetParser = prism' (T.pack . unlines . V.toList . fmap (show . pretty)) $ \t -> case parse puppetParser "dummy" t of
Left _ -> Nothing
Right r -> Just r
_PrettyError :: Prism' SomeException PrettyError
_PrettyError = prism' toException fromException
_ResDecl :: Prism' Statement ResDecl
_ResDecl = prism ResourceDeclaration $ \x -> case x of
ResourceDeclaration a -> Right a
_ -> Left x
_ResDefaultDecl :: Prism' Statement ResDefaultDecl
_ResDefaultDecl = prism ResourceDefaultDeclaration $ \x -> case x of
ResourceDefaultDeclaration a -> Right a
_ -> Left x
_ResOverrDecl :: Prism' Statement ResOverrideDecl
_ResOverrDecl = prism ResourceOverrideDeclaration $ \x -> case x of
ResourceOverrideDeclaration a -> Right a
_ -> Left x
_ResCollDecl :: Prism' Statement ResCollDecl
_ResCollDecl = prism ResourceCollectionDeclaration $ \x -> case x of
ResourceCollectionDeclaration a -> Right a
_ -> Left x
_ConditionalDecl :: Prism' Statement ConditionalDecl
_ConditionalDecl = prism ConditionalDeclaration $ \x -> case x of
ConditionalDeclaration a -> Right a
_ -> Left x
_ClassDecl :: Prism' Statement ClassDecl
_ClassDecl = prism ClassDeclaration $ \x -> case x of
ClassDeclaration a -> Right a
_ -> Left x
_DefineDecl :: Prism' Statement DefineDecl
_DefineDecl = prism DefineDeclaration $ \x -> case x of
DefineDeclaration a -> Right a
_ -> Left x
_NodeDecl :: Prism' Statement NodeDecl
_NodeDecl = prism NodeDeclaration $ \x -> case x of
NodeDeclaration a -> Right a
_ -> Left x
_VarAssignDecl :: Prism' Statement VarAssignDecl
_VarAssignDecl = prism VarAssignmentDeclaration $ \x -> case x of
VarAssignmentDeclaration a -> Right a
_ -> Left x
_MainFuncDecl :: Prism' Statement MainFuncDecl
_MainFuncDecl = prism MainFunctionDeclaration $ \x -> case x of
MainFunctionDeclaration a -> Right a
_ -> Left x
_HigherOrderLambdaDecl :: Prism' Statement HigherOrderLambdaDecl
_HigherOrderLambdaDecl = prism HigherOrderLambdaDeclaration $ \x -> case x of
HigherOrderLambdaDeclaration a -> Right a
_ -> Left x
_DepDecl :: Prism' Statement DepDecl
_DepDecl = prism DependencyDeclaration $ \x -> case x of
DependencyDeclaration a -> Right a
_ -> Left x
_TopContainer :: Prism' Statement (V.Vector Statement, Statement)
_TopContainer = prism (uncurry TopContainer) $ \x -> case x of
TopContainer vs s -> Right (vs,s)
_ -> Left x
-- | Incomplete
_PResolveExpression :: Prism' Expression PValue
_PResolveExpression = prism reinject extract
where
extract e = case dummyEval (resolveExpression e) of
Right x -> Right x
Left _ -> Left e
reinject = Terminal . review _PResolveValue
_PResolveValue :: Prism' UnresolvedValue PValue
_PResolveValue = prism toU toP
where
toP uv = case dummyEval (resolveValue uv) of
Right x -> Right x
Left _ -> Left uv
toU (PBoolean x) = UBoolean x
toU (PNumber x) = UNumber x
toU PUndef = UUndef
toU (PString s) = UString s
toU (PResourceReference t n) = UResourceReference t (Terminal (UString n))
toU (PArray r) = UArray (fmap (Terminal . toU) r)
toU (PHash h) = UHash (V.fromList $ map (\(k,v) -> (Terminal (UString k) :!: Terminal (toU v))) $ HM.toList h)
toU (PType _) = error "TODO, _PResolveValue PType undefined"
_Statements :: Lens' Statement [Statement]
_Statements = lens (V.toList . sget) (\s v -> sset s (V.fromList v))
where
sget :: Statement -> V.Vector Statement
sget (ClassDeclaration (ClassDecl _ _ _ s _)) = s
sget (DefineDeclaration (DefineDecl _ _ s _)) = s
sget (NodeDeclaration (NodeDecl _ s _ _)) = s
sget (TopContainer s _) = s
sget (HigherOrderLambdaDeclaration (HigherOrderLambdaDecl (HOLambdaCall _ _ _ s _) _)) = s
sget _ = V.empty
sset :: Statement -> V.Vector Statement -> Statement
sset (ClassDeclaration (ClassDecl n args inh _ p)) s = ClassDeclaration (ClassDecl n args inh s p)
sset (NodeDeclaration (NodeDecl ns _ nd' p)) s = NodeDeclaration (NodeDecl ns s nd' p)
sset (DefineDeclaration (DefineDecl n args _ p)) s = DefineDeclaration (DefineDecl n args s p)
sset (TopContainer _ p) s = TopContainer s p
sset (HigherOrderLambdaDeclaration (HigherOrderLambdaDecl (HOLambdaCall t e pr _ e2) p)) s = HigherOrderLambdaDeclaration (HigherOrderLambdaDecl (HOLambdaCall t e pr s e2) p)
sset x _ = x