module Data.Spec.Analysis
( AnalysisResult(..)
, specAnalyze
)
where
import qualified Copilot.Core as Core
import Data.List (intercalate, lookup)
import Data.Maybe (fromMaybe)
import Data.String.Extra (sanitizeLCIdentifier, sanitizeUCIdentifier)
import Data.OgmaSpec (ExternalVariableDef (..), InternalVariableDef (..),
Requirement (..), Spec (..))
import Copilot.Core.Analysis (exprIsConstant)
import Copilot.Language.Reify.Extra (reifySpec)
data AnalysisResult = AnalysisResult
{ AnalysisResult -> Int
numAlwaysTrue :: Int
, AnalysisResult -> Int
numAlwaysFalse :: Int
, AnalysisResult -> [String]
alwaysTrueReq :: [String]
, AnalysisResult -> [String]
alwaysFalseReq :: [String]
, AnalysisResult -> Bool
consistent :: Bool
}
specAnalyze :: [(String, String)]
-> ([(String, String)] -> a -> a)
-> (a -> String)
-> Spec a
-> IO (Either String AnalysisResult)
specAnalyze :: forall a.
[(String, String)]
-> ([(String, String)] -> a -> a)
-> (a -> String)
-> Spec a
-> IO (Either String AnalysisResult)
specAnalyze [(String, String)]
typeMaps [(String, String)] -> a -> a
exprTransform a -> String
showExpr Spec a
spec = do
let structuredSpec :: CopilotSpec
structuredSpec =
[(String, String)]
-> ([(String, String)] -> a -> a)
-> (a -> String)
-> Spec a
-> CopilotSpec
forall a.
[(String, String)]
-> ([(String, String)] -> a -> a)
-> (a -> String)
-> Spec a
-> CopilotSpec
spec2Copilot [(String, String)]
typeMaps [(String, String)] -> a -> a
exprTransform a -> String
showExpr Spec a
spec
coreSpec <- [(String, Maybe String)] -> String -> IO Spec
reifySpec [(String, Maybe String)]
defaultSpecImports (String -> IO Spec) -> String -> IO Spec
forall a b. (a -> b) -> a -> b
$ CopilotSpec -> String
showSpec CopilotSpec
structuredSpec
let properties = [String] -> [Expr Bool] -> [(String, Expr Bool)]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
propertyNames [Expr Bool]
propertyGuards
propertyNames = ((String, String, String, String, String) -> String)
-> [(String, String, String, String, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\(String
_, String
p, String
_, String
_, String
_) -> String
p)
([(String, String, String, String, String)] -> [String])
-> [(String, String, String, String, String)] -> [String]
forall a b. (a -> b) -> a -> b
$ CopilotSpec -> [(String, String, String, String, String)]
copilotProperties CopilotSpec
structuredSpec
propertyGuards = (Trigger -> Expr Bool) -> [Trigger] -> [Expr Bool]
forall a b. (a -> b) -> [a] -> [b]
map Trigger -> Expr Bool
Core.triggerGuard ([Trigger] -> [Expr Bool]) -> [Trigger] -> [Expr Bool]
forall a b. (a -> b) -> a -> b
$ Spec -> [Trigger]
Core.specTriggers Spec
coreSpec
constantProperties <- mapM (uncurry $ exprIsConstant coreSpec) properties
let constantProperties' = [String] -> [(Bool, Bool)] -> [(String, (Bool, Bool))]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
propertyNames [(Bool, Bool)]
constantProperties
let numTrue = [(Bool, Bool)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([(Bool, Bool)] -> Int) -> [(Bool, Bool)] -> Int
forall a b. (a -> b) -> a -> b
$ ((Bool, Bool) -> Bool) -> [(Bool, Bool)] -> [(Bool, Bool)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool, Bool) -> Bool
forall a b. (a, b) -> a
fst [(Bool, Bool)]
constantProperties
numFalse = [(Bool, Bool)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([(Bool, Bool)] -> Int) -> [(Bool, Bool)] -> Int
forall a b. (a -> b) -> a -> b
$ ((Bool, Bool) -> Bool) -> [(Bool, Bool)] -> [(Bool, Bool)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool, Bool) -> Bool
forall a b. (a, b) -> b
snd [(Bool, Bool)]
constantProperties
trueReqs = ((String, (Bool, Bool)) -> String)
-> [(String, (Bool, Bool))] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, (Bool, Bool)) -> String
forall a b. (a, b) -> a
fst ([(String, (Bool, Bool))] -> [String])
-> [(String, (Bool, Bool))] -> [String]
forall a b. (a -> b) -> a -> b
$ ((String, (Bool, Bool)) -> Bool)
-> [(String, (Bool, Bool))] -> [(String, (Bool, Bool))]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Bool, Bool) -> Bool
forall a b. (a, b) -> a
fst ((Bool, Bool) -> Bool)
-> ((String, (Bool, Bool)) -> (Bool, Bool))
-> (String, (Bool, Bool))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, (Bool, Bool)) -> (Bool, Bool)
forall a b. (a, b) -> b
snd) [(String, (Bool, Bool))]
constantProperties'
falseReqs = ((String, (Bool, Bool)) -> String)
-> [(String, (Bool, Bool))] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, (Bool, Bool)) -> String
forall a b. (a, b) -> a
fst ([(String, (Bool, Bool))] -> [String])
-> [(String, (Bool, Bool))] -> [String]
forall a b. (a -> b) -> a -> b
$ ((String, (Bool, Bool)) -> Bool)
-> [(String, (Bool, Bool))] -> [(String, (Bool, Bool))]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Bool, Bool) -> Bool
forall a b. (a, b) -> b
snd ((Bool, Bool) -> Bool)
-> ((String, (Bool, Bool)) -> (Bool, Bool))
-> (String, (Bool, Bool))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, (Bool, Bool)) -> (Bool, Bool)
forall a b. (a, b) -> b
snd) [(String, (Bool, Bool))]
constantProperties'
let negatedConjunction = Op1 Bool Bool -> Expr Bool -> Expr Bool
forall a1 a. Typeable a1 => Op1 a1 a -> Expr a1 -> Expr a
Core.Op1 Op1 Bool Bool
Core.Not
(Expr Bool -> Expr Bool) -> Expr Bool -> Expr Bool
forall a b. (a -> b) -> a -> b
$ (Expr Bool -> Expr Bool -> Expr Bool)
-> Expr Bool -> [Expr Bool] -> Expr Bool
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Op2 Bool Bool Bool -> Expr Bool -> Expr Bool -> Expr Bool
forall a1 b a.
(Typeable a1, Typeable b) =>
Op2 a1 b a -> Expr a1 -> Expr b -> Expr a
Core.Op2 Op2 Bool Bool Bool
Core.And) Expr Bool
true [Expr Bool]
propertyGuards
true = Type Bool -> Bool -> Expr Bool
forall a. Typeable a => Type a -> a -> Expr a
Core.Const Type Bool
Core.Bool Bool
True
provedNegatedConjunction <-
exprIsConstant coreSpec "ogma_inc" negatedConjunction
let consistent = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (Bool, Bool) -> Bool
forall a b. (a, b) -> a
fst (Bool, Bool)
provedNegatedConjunction
return $ Right $
AnalysisResult numTrue numFalse trueReqs falseReqs consistent
data CopilotSpec = CopilotSpec
{ CopilotSpec -> [(String, String, String, String, String)]
copilotProperties :: [(String, String, String, String, String)]
, CopilotSpec -> [(String, String, String)]
copilotAuxDefs :: [(String, String, String)]
}
spec2Copilot :: [(String, String)]
-> ([(String, String)] -> a -> a)
-> (a -> String)
-> Spec a
-> CopilotSpec
spec2Copilot :: forall a.
[(String, String)]
-> ([(String, String)] -> a -> a)
-> (a -> String)
-> Spec a
-> CopilotSpec
spec2Copilot [(String, String)]
typeMaps [(String, String)] -> a -> a
exprTransform a -> String
showExpr Spec a
spec = [(String, String, String, String, String)]
-> [(String, String, String)] -> CopilotSpec
CopilotSpec [(String, String, String, String, String)]
reqs [(String, String, String)]
auxDefs
where
reqs :: [(String, String, String, String, String)]
reqs :: [(String, String, String, String, String)]
reqs = (Requirement a -> (String, String, String, String, String))
-> [Requirement a] -> [(String, String, String, String, String)]
forall a b. (a -> b) -> [a] -> [b]
map Requirement a -> (String, String, String, String, String)
reqToDecl (Spec a -> [Requirement a]
forall a. Spec a -> [Requirement a]
requirements Spec a
spec)
where
reqToDecl :: Requirement a -> (String, String, String, String, String)
reqToDecl Requirement a
i =
( String
reqName
, String
propName
, String
handlerName
, [(String, String)] -> String
reqBody [(String, String)]
nameSubstitutions
, String
handlerArg
)
where
reqName :: String
reqName = Requirement a -> String
forall a. Requirement a -> String
requirementName Requirement a
i
propName :: String
propName = [(String, String)] -> String -> String
forall k. Eq k => [(k, k)] -> k -> k
safeMap [(String, String)]
nameSubstitutions (Requirement a -> String
forall a. Requirement a -> String
requirementName Requirement a
i)
handlerName :: String
handlerName = String
"handler" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
sanitizeUCIdentifier (Requirement a -> String
forall a. Requirement a -> String
requirementName Requirement a
i)
reqBody :: [(String, String)] -> String
reqBody [(String, String)]
subs = a -> String
showExpr ([(String, String)] -> a -> a
exprTransform [(String, String)]
subs (Requirement a -> a
forall a. Requirement a -> a
requirementExpr Requirement a
i))
handlerArg :: String
handlerArg =
case (Requirement a -> Maybe String
forall a. Requirement a -> Maybe String
requirementResultType Requirement a
i, Requirement a -> Maybe a
forall a. Requirement a -> Maybe a
requirementResultExpr Requirement a
i) of
(Just String
_, Just a
ex) -> String
"[ arg (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
showExpr a
ex String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" ) ]"
(Maybe String, Maybe a)
_ -> String
"[]"
auxDefs :: [(String, String, String)]
auxDefs :: [(String, String, String)]
auxDefs = [(String, String, String)]
externs [(String, String, String)]
-> [(String, String, String)] -> [(String, String, String)]
forall a. [a] -> [a] -> [a]
++ [(String, String, String)]
internals
externs :: [(String, String, String)]
externs :: [(String, String, String)]
externs = (ExternalVariableDef -> (String, String, String))
-> [ExternalVariableDef] -> [(String, String, String)]
forall a b. (a -> b) -> [a] -> [b]
map ExternalVariableDef -> (String, String, String)
externVarToDecl (Spec a -> [ExternalVariableDef]
forall a. Spec a -> [ExternalVariableDef]
externalVariables Spec a
spec)
where
externVarToDecl :: ExternalVariableDef -> (String, String, String)
externVarToDecl ExternalVariableDef
i = (String
propName, String
streamType, String
implementation)
where
propName :: String
propName = [(String, String)] -> String -> String
forall k. Eq k => [(k, k)] -> k -> k
safeMap [(String, String)]
nameSubstitutions (ExternalVariableDef -> String
externalVariableName ExternalVariableDef
i)
streamType :: String
streamType = String
"Stream " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
valueType String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
valueType :: String
valueType = [(String, String)] -> String -> String
forall k. Eq k => [(k, k)] -> k -> k
safeMap [(String, String)]
typeMaps (ExternalVariableDef -> String
externalVariableType ExternalVariableDef
i)
implementation :: String
implementation = String
"extern" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show (ExternalVariableDef -> String
externalVariableName ExternalVariableDef
i)
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Nothing"
internals :: [(String, String, String)]
internals :: [(String, String, String)]
internals = (InternalVariableDef -> (String, String, String))
-> [InternalVariableDef] -> [(String, String, String)]
forall a b. (a -> b) -> [a] -> [b]
map InternalVariableDef -> (String, String, String)
internalVarToDecl (Spec a -> [InternalVariableDef]
forall a. Spec a -> [InternalVariableDef]
internalVariables Spec a
spec)
where
internalVarToDecl :: InternalVariableDef -> (String, String, String)
internalVarToDecl InternalVariableDef
i = (String
propName, String
streamType, String
implementation)
where
propName :: String
propName = [(String, String)] -> String -> String
forall k. Eq k => [(k, k)] -> k -> k
safeMap [(String, String)]
nameSubstitutions (InternalVariableDef -> String
internalVariableName InternalVariableDef
i)
streamType :: String
streamType = String
"Stream " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
valueType String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
valueType :: String
valueType = [(String, String)] -> String -> String
forall k. Eq k => [(k, k)] -> k -> k
safeMap [(String, String)]
typeMaps (InternalVariableDef -> String
internalVariableType InternalVariableDef
i)
implementation :: String
implementation = InternalVariableDef -> String
internalVariableExpr InternalVariableDef
i
nameSubstitutions :: [(String, String)]
nameSubstitutions = [(String, String)]
internalVariableMap
[(String, String)] -> [(String, String)] -> [(String, String)]
forall a. [a] -> [a] -> [a]
++ [(String, String)]
externalVariableMap
[(String, String)] -> [(String, String)] -> [(String, String)]
forall a. [a] -> [a] -> [a]
++ [(String, String)]
requirementNameMap
internalVariableMap :: [(String, String)]
internalVariableMap =
(String -> (String, String)) -> [String] -> [(String, String)]
forall a b. (a -> b) -> [a] -> [b]
map (\String
x -> (String
x, String -> String
sanitizeLCIdentifier String
x)) [String]
internalVariableNames
externalVariableMap :: [(String, String)]
externalVariableMap =
(String -> (String, String)) -> [String] -> [(String, String)]
forall a b. (a -> b) -> [a] -> [b]
map (\String
x -> (String
x, String -> String
sanitizeLCIdentifier String
x)) [String]
externalVariableNames
requirementNameMap :: [(String, String)]
requirementNameMap =
(String -> (String, String)) -> [String] -> [(String, String)]
forall a b. (a -> b) -> [a] -> [b]
map (\String
x -> (String
x, String
"prop" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
sanitizeUCIdentifier String
x)) [String]
requirementNames
internalVariableNames :: [String]
internalVariableNames = (InternalVariableDef -> String)
-> [InternalVariableDef] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map InternalVariableDef -> String
internalVariableName
([InternalVariableDef] -> [String])
-> [InternalVariableDef] -> [String]
forall a b. (a -> b) -> a -> b
$ Spec a -> [InternalVariableDef]
forall a. Spec a -> [InternalVariableDef]
internalVariables Spec a
spec
externalVariableNames :: [String]
externalVariableNames = (ExternalVariableDef -> String)
-> [ExternalVariableDef] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ExternalVariableDef -> String
externalVariableName
([ExternalVariableDef] -> [String])
-> [ExternalVariableDef] -> [String]
forall a b. (a -> b) -> a -> b
$ Spec a -> [ExternalVariableDef]
forall a. Spec a -> [ExternalVariableDef]
externalVariables Spec a
spec
requirementNames :: [String]
requirementNames = (Requirement a -> String) -> [Requirement a] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Requirement a -> String
forall a. Requirement a -> String
requirementName
([Requirement a] -> [String]) -> [Requirement a] -> [String]
forall a b. (a -> b) -> a -> b
$ Spec a -> [Requirement a]
forall a. Spec a -> [Requirement a]
requirements Spec a
spec
showSpec :: CopilotSpec -> String
showSpec :: CopilotSpec -> String
showSpec CopilotSpec
spec = String
template String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
extra String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
triggers
where
template :: String
template :: String
template = [String] -> String
unlines
[ String
"do let"
, String
""
, String
" clock :: Stream Int64"
, String
" clock = [0] ++ (clock + 1)"
, String
""
, String
" ftp :: Stream Bool"
, String
" ftp = [True] ++ false"
, String
""
, String
" pre :: Stream Bool -> Stream Bool"
, String
" pre = ([False] ++)"
, String
""
, String
" tpre :: Stream Bool -> Stream Bool"
, String
" tpre = ([True] ++)"
, String
""
, String
" notPreviousNot :: Stream Bool -> Stream Bool"
, String
" notPreviousNot = not . PTLTL.previous . not"
]
extra :: String
extra = [String] -> String
unlines
([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [String] -> [[String]] -> [String]
forall a. [a] -> [[a]] -> [a]
intercalate [String
""]
([[String]] -> [String]) -> [[String]] -> [String]
forall a b. (a -> b) -> a -> b
$ ((String, String, String) -> [String])
-> [(String, String, String)] -> [[String]]
forall a b. (a -> b) -> [a] -> [b]
map (String, String, String) -> [String]
formatDef
([(String, String, String)] -> [[String]])
-> [(String, String, String)] -> [[String]]
forall a b. (a -> b) -> a -> b
$ CopilotSpec -> [(String, String, String)]
copilotAuxDefs CopilotSpec
spec
triggers :: String
triggers = [String] -> String
unlines
([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [String] -> [[String]] -> [String]
forall a. [a] -> [[a]] -> [a]
intercalate [String
""]
([[String]] -> [String]) -> [[String]] -> [String]
forall a b. (a -> b) -> a -> b
$ ((String, String, String, String, String) -> [String])
-> [(String, String, String, String, String)] -> [[String]]
forall a b. (a -> b) -> [a] -> [b]
map (String, String, String, String, String) -> [String]
forall {a} {a} {b}. Show a => (a, b, a, String, String) -> [String]
formatTrigger
([(String, String, String, String, String)] -> [[String]])
-> [(String, String, String, String, String)] -> [[String]]
forall a b. (a -> b) -> a -> b
$ CopilotSpec -> [(String, String, String, String, String)]
copilotProperties CopilotSpec
spec
formatDef :: (String, String, String) -> [String]
formatDef (String
n, String
t, String
i) =
(String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++) [ String
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" :: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
t, String
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
i ]
formatTrigger :: (a, b, a, String, String) -> [String]
formatTrigger (a
_, b
_, a
h, String
g, String
a) =
(String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++) [ String
"trigger " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
h String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
g String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
a ]
defaultSpecImports :: [(String, Maybe String)]
defaultSpecImports :: [(String, Maybe String)]
defaultSpecImports =
[ (String
"Control.Monad.Writer", Maybe String
forall a. Maybe a
Nothing)
, (String
"Copilot.Language", Maybe String
forall a. Maybe a
Nothing)
, (String
"Copilot.Language.Spec", Maybe String
forall a. Maybe a
Nothing)
, (String
"Data.Functor.Identity", Maybe String
forall a. Maybe a
Nothing)
, (String
"Language.Copilot", Maybe String
forall a. Maybe a
Nothing)
, (String
"Copilot.Library.PTLTL", String -> Maybe String
forall a. a -> Maybe a
Just String
"PTLTL")
, (String
"Prelude", String -> Maybe String
forall a. a -> Maybe a
Just String
"P")
]
safeMap :: Eq k => [(k, k)] -> k -> k
safeMap :: forall k. Eq k => [(k, k)] -> k -> k
safeMap [(k, k)]
ls k
k = k -> Maybe k -> k
forall a. a -> Maybe a -> a
fromMaybe k
k (Maybe k -> k) -> Maybe k -> k
forall a b. (a -> b) -> a -> b
$ k -> [(k, k)] -> Maybe k
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup k
k [(k, k)]
ls