module Language.Clafer (addModuleFragment,
compile,
parse,
generate,
generateHtml,
generateFragments,
runClaferT,
runClafer,
ClaferErr,
getEnv,
putEnv,
CompilerResult(..),
claferIRXSD,
VerbosityL,
InputModel,
Token,
Module,
GEnv,
IModule,
voidf,
ClaferEnv(..),
getIr,
getAst,
makeEnv,
Pos(..),
IrTrace(..),
module Language.Clafer.ClaferArgs,
module Language.Clafer.Front.ErrM)
where
import Data.Either
import Data.List
import Data.Maybe
import qualified Data.Map as Map
import Data.Ord
import Control.Monad
import System.FilePath (takeBaseName)
import Language.ClaferT
import Language.Clafer.Common
import Language.Clafer.Front.ErrM
import Language.Clafer.ClaferArgs hiding (Clafer)
import qualified Language.Clafer.ClaferArgs as Mode (ClaferMode (Clafer))
import Language.Clafer.Comments
import qualified Language.Clafer.Css as Css
import Language.Clafer.Front.Lexclafer
import Language.Clafer.Front.Parclafer
import Language.Clafer.Front.Printclafer
import Language.Clafer.Front.Absclafer
import Language.Clafer.Front.LayoutResolver
import Language.Clafer.Front.Mapper
import Language.Clafer.Intermediate.Tracing
import Language.Clafer.Intermediate.Intclafer
import Language.Clafer.Intermediate.Desugarer
import Language.Clafer.Intermediate.Resolver
import Language.Clafer.Intermediate.StringAnalyzer
import Language.Clafer.Intermediate.Transformer
import Language.Clafer.Intermediate.ScopeAnalysis
import Language.Clafer.Optimizer.Optimizer
import Language.Clafer.Generator.Alloy
import Language.Clafer.Generator.Choco
import Language.Clafer.Generator.Xml
import Language.Clafer.Generator.Python
import Language.Clafer.Generator.Schema
import Language.Clafer.Generator.Stats
import Language.Clafer.Generator.Html
import Language.Clafer.Generator.Graph
type VerbosityL = Int
type InputModel = String
addModuleFragment :: Monad m => InputModel -> ClaferT m ()
addModuleFragment i =
do
env <- getEnv
let modelFrags' = modelFrags env ++ [i]
let frags' = frags env ++ [(endPos $ concat modelFrags')]
putEnv env{ modelFrags = modelFrags', frags = frags' }
where
endPos "" = Pos 1 1
endPos model =
Pos line' column'
where
input' = lines' model
line' = toInteger $ length input'
column' = 1 + (toInteger $ length $ last input')
lines' "" = [""]
lines' input'' =
line'' : rest'
where
(line'', rest) = break (== '\n') input''
rest' =
case rest of
"" -> []
('\n' : r) -> lines' r
x -> error $ "linesing " ++ x
liftParseErrs :: Monad m => [Err a] -> ClaferT m [a]
liftParseErrs e =
do
result <- zipWithM extract [0..] e
case partitionEithers result of
([], ok) -> return ok
(e', _) -> throwErrs e'
where
extract _ (Ok m) = return $ Right m
extract frgId (Bad p s) =
do
return $ Left $ ParseErr (ErrFragPos frgId p) s
liftParseErr :: Monad m => Err a -> ClaferT m a
liftParseErr e = head `liftM` liftParseErrs [e]
parse :: Monad m => ClaferT m ()
parse =
do
env <- getEnv
astsErr <- mapM (parseFrag $ args env) $ modelFrags env
asts <- liftParseErrs astsErr
ast' <- case asts of
[oneFrag] -> return oneFrag
_ -> do
let completeModel = concat $ modelFrags env
completeAst <- (parseFrag $ args env) completeModel
liftParseErr completeAst
let ast = mapModule ast'
let env' = env{ cAst = Just ast, astModuleTrace = traceAstModule ast }
putEnv env'
where
parseFrag :: (Monad m) => ClaferArgs -> String -> ClaferT m (Err Module)
parseFrag args' =
(>>= (return . pModule)) .
(if not
((new_layout args') ||
(no_layout args'))
then
resolveLayout
else
return)
. myLexer .
(if (not $ no_layout args') &&
(new_layout args')
then
resLayout
else
id)
compile :: Monad m => ClaferT m ()
compile =
do
env <- getEnv
ast' <- getAst
let desugaredMod = desugar ast'
let clafersWithKeyWords = foldMapIR isKeyWord desugaredMod
when (""/=clafersWithKeyWords) $ throwErr (ClaferErr $ ("The model contains clafers with keywords as names in the following places:\n"++) $ clafersWithKeyWords :: CErr Span)
ir <- analyze (args env) desugaredMod
let (imodule, _, _) = ir
let spanList = foldMapIR gt1 imodule
when ((afm $ args env) && spanList/="") $ throwErr (ClaferErr $ ("The model is not an attributed feature model.\nThe following places contain cardinality larger than 1:\n"++) $ spanList :: CErr Span)
putEnv $ env{ cIr = Just ir, irModuleTrace = traceIrModule imodule }
where
isKeyWord :: Ir -> String
isKeyWord (IRClafer IClafer{cinPos = (Span (Pos l c) _) ,ident=i}) = if (i `elem` keyWords) then ("Line " ++ show l ++ " column " ++ show c ++ "\n") else ""
isKeyWord (IRClafer IClafer{cinPos = (PosSpan _ (Pos l c) _) ,ident=i}) = if (i `elem` keyWords) then ("Line " ++ show l ++ " column " ++ show c ++ "\n") else ""
isKeyWord (IRClafer IClafer{cinPos = (Span (PosPos _ l c) _) ,ident=i}) = if (i `elem` keyWords) then ("Line " ++ show l ++ " column " ++ show c ++ "\n") else ""
isKeyWord (IRClafer IClafer{cinPos = (PosSpan _ (PosPos _ l c) _) ,ident=i}) = if (i `elem` keyWords) then ("Line " ++ show l ++ " column " ++ show c ++ "\n") else ""
isKeyWord _ = ""
gt1 :: Ir -> String
gt1 (IRClafer (IClafer (Span (Pos l c) _) False _ _ _ _ (Just (_, m)) _ _)) = if (m > 1 || m < 0) then ("Line " ++ show l ++ " column " ++ show c ++ "\n") else ""
gt1 (IRClafer (IClafer (Span (PosPos _ l c) _) False _ _ _ _ (Just (_, m)) _ _)) = if (m > 1 || m < 0) then ("Line " ++ show l ++ " column " ++ show c ++ "\n") else ""
gt1 (IRClafer (IClafer (PosSpan _ (Pos l c) _) False _ _ _ _ (Just (_, m)) _ _)) = if (m > 1 || m < 0) then ("Line " ++ show l ++ " column " ++ show c ++ "\n") else ""
gt1 (IRClafer (IClafer (PosSpan _ (PosPos _ l c) _) False _ _ _ _ (Just (_, m)) _ _)) = if (m > 1 || m < 0) then ("Line " ++ show l ++ " column " ++ show c ++ "\n") else ""
gt1 _ = ""
generateFragments :: Monad m => ClaferT m [String]
generateFragments =
do
env <- getEnv
(iModule, _, _) <- getIr
fragElems <- fragment (sortBy (comparing rnge) $ mDecls iModule) (frags env)
return $ map (generateFragment $ args env) fragElems
where
rnge (IEClafer IClafer{cinPos = p}) = p
rnge IEConstraint{cpexp = PExp{inPos = p}} = p
rnge IEGoal{cpexp = PExp{inPos = p}} = p
fragment :: (Monad m) => [IElement] -> [Pos] -> ClaferT m [[IElement]]
fragment [] [] = return []
fragment elems (frag : rest) =
fragment restFrags rest >>= return . (curFrag:)
where
(curFrag, restFrags) = span (`beforePos` frag) elems
fragment _ [] = throwErr $ (ClaferErr $ "Unexpected fragment." :: CErr Span)
beforePos ele p =
case rnge ele of
Span _ e -> e <= p
PosSpan _ _ e -> e <= p
generateFragment :: ClaferArgs -> [IElement] -> String
generateFragment args' frag =
flatten $ cconcat $ map (genDeclaration args') frag
generateHtml :: ClaferEnv -> Module -> String
generateHtml env ast' =
let PosModule _ decls' = ast';
cargs = args env;
irMap = irModuleTrace env;
comments = if add_comments cargs then getComments $ unlines $ modelFrags env else [];
in (if (self_contained cargs) then Css.header ++ "<style>" ++ Css.css ++ "</style></head>\n<body>\n" else "")
++ (unlines $ genFragments decls' (frags env) irMap comments) ++
(if (self_contained cargs) then "</body>\n</html>" else "")
where
lne (PosElementDecl (Span p _) _) = p
lne (PosEnumDecl (Span p _) _ _) = p
lne _ = Pos 0 0
genFragments :: [Declaration] -> [Pos] -> Map.Map Span [Ir] -> [(Span, String)] -> [String]
genFragments [] _ _ comments = printComments comments
genFragments (decl:decls') [] irMap comments = let (comments', c) = printPreComment (range decl) comments in
[c] ++ (cleanOutput $ revertLayout $ printDeclaration decl 0 irMap True $ inDecl decl comments') : (genFragments decls' [] irMap $ afterDecl decl comments)
genFragments (decl:decls') (frg:frgs) irMap comments = if lne decl < frg
then let (comments', c) = printPreComment (range decl) comments in
[c] ++ (cleanOutput $ revertLayout $ printDeclaration decl 0 irMap True $ inDecl decl comments') : (genFragments decls' (frg:frgs) irMap $ afterDecl decl comments)
else "<!-- # FRAGMENT /-->" : genFragments (decl:decls') frgs irMap comments
inDecl :: Declaration -> [(Span, String)] -> [(Span, String)]
inDecl decl comments = let s = rnge decl in dropWhile (\x -> fst x < s) comments
afterDecl :: Declaration -> [(Span, String)] -> [(Span, String)]
afterDecl decl comments = let (Span _ (Pos line' _)) = rnge decl in dropWhile (\(x, _) -> let (Span _ (Pos line'' _)) = x in line'' <= line') comments
rnge (EnumDecl _ _) = noSpan
rnge (PosEnumDecl s _ _) = s
rnge (ElementDecl _) = noSpan
rnge (PosElementDecl s _) = s
printComments [] = []
printComments ((s, comment):cs) = (snd (printComment s [(s, comment)]) ++ "<br>\n"):printComments cs
generate :: Monad m => ClaferT m (Map.Map ClaferMode CompilerResult)
generate =
do
env <- getEnv
ast' <- getAst
(iModule, genv, au) <- getIr
let
cargs = args env
stats = showStats au $ statsModule iModule
modes = mode cargs
scopes = getScopeStrategy (scope_strategy cargs) iModule
return $ Map.fromList (
(if (Alloy `elem` modes)
then let
(imod,strMap) = astrModule iModule
alloyCode = genModule cargs{mode = [Alloy]} (imod, genv) scopes
addCommentStats = if no_stats cargs then const else addStats
in
[ (Alloy,
CompilerResult {
extension = "als",
outputCode = addCommentStats (fst alloyCode) stats,
statistics = stats,
claferEnv = env,
mappingToAlloy = fromMaybe [] (Just $ snd alloyCode),
stringMap = strMap,
scopesList = scopes
})
]
else []
)
++
(if (Alloy42 `elem` modes)
then let
(imod,strMap) = astrModule iModule
alloyCode = genModule cargs{mode = [Alloy42]} (imod, genv) scopes
addCommentStats = if no_stats cargs then const else addStats
in
[ (Alloy42,
CompilerResult {
extension = "als4",
outputCode = addCommentStats (fst alloyCode) stats,
statistics = stats,
claferEnv = env,
mappingToAlloy = fromMaybe [] (Just $ snd alloyCode),
stringMap = strMap,
scopesList = scopes
})
]
else []
)
++ (if (Xml `elem` modes)
then [ (Xml,
CompilerResult {
extension = "xml",
outputCode = genXmlModule iModule,
statistics = stats,
claferEnv = env,
mappingToAlloy = [],
stringMap = Map.empty,
scopesList = []
}) ]
else []
)
++ (if (Mode.Clafer `elem` modes)
then [ (Mode.Clafer,
CompilerResult {
extension = "des.cfr",
outputCode = printTree $ sugarModule iModule,
statistics = stats,
claferEnv = env,
mappingToAlloy = [],
stringMap = Map.empty,
scopesList = []
}) ]
else []
)
++ (if (Html `elem` modes)
then [ (Html,
CompilerResult {
extension = "html",
outputCode = generateHtml env ast',
statistics = stats,
claferEnv = env,
mappingToAlloy = [],
stringMap = Map.empty,
scopesList = []
}) ]
else []
)
++ (if (Graph `elem` modes)
then [ (Graph,
CompilerResult {
extension = "dot",
outputCode = genSimpleGraph ast' iModule (takeBaseName $ file cargs) (show_references cargs),
statistics = stats,
claferEnv = env,
mappingToAlloy = [],
stringMap = Map.empty,
scopesList = []
}) ]
else []
)
++ (if (CVLGraph `elem` modes)
then [ (CVLGraph,
CompilerResult {
extension = "cvl.dot",
outputCode = genCVLGraph ast' iModule (takeBaseName $ file cargs),
statistics = stats,
claferEnv = env,
mappingToAlloy = [],
stringMap = Map.empty,
scopesList = []
}) ]
else []
)
++ (if (Python `elem` modes)
then [ (Python,
CompilerResult {
extension = "py",
outputCode = genPythonModule iModule,
statistics = stats,
claferEnv = env,
mappingToAlloy = [],
stringMap = Map.empty,
scopesList = scopes
}) ]
else []
)
++ (if (Choco `elem` modes)
then let
(imod,strMap) = astrModule iModule
in
[ (Choco,
CompilerResult {
extension = "js",
outputCode = genCModule cargs (imod, genv) scopes,
statistics = stats,
claferEnv = env,
mappingToAlloy = [],
stringMap = strMap,
scopesList = scopes
}) ]
else []
))
data CompilerResult = CompilerResult {
extension :: String,
outputCode :: String,
statistics :: String,
claferEnv :: ClaferEnv,
mappingToAlloy :: [(Span, IrTrace)],
stringMap :: (Map.Map Int String),
scopesList :: [(UID, Integer)]
} deriving Show
desugar :: Module -> IModule
desugar tree = desugarModule tree
liftError :: (Monad m, Language.ClaferT.Throwable t) => Either t a -> ClaferT m a
liftError = either throwErr return
analyze :: Monad m => ClaferArgs -> IModule -> ClaferT m (IModule, GEnv, Bool)
analyze args' tree = do
let dTree' = findDupModule args' tree
let au = allUnique dTree'
let args'' = args'{skip_resolver = au && (skip_resolver args')}
(rTree, genv) <- liftError $ resolveModule args'' dTree'
let tTree = transModule rTree
return (optimizeModule args'' (tTree, genv), genv, au)
addStats :: String -> String -> String
addStats code stats = "/*\n" ++ stats ++ "*/\n" ++ code
showStats :: Bool -> Stats -> String
showStats au (Stats na nr nc nconst ngoals sgl) =
unlines [ "All clafers: " ++ (show (na + nr + nc)) ++ " | Abstract: " ++ (show na) ++ " | Concrete: " ++ (show nc) ++ " | References: " ++ (show nr) , "Constraints: " ++ show nconst
, "Goals: " ++ show ngoals
, "Global scope: " ++ showInterval sgl
, "Can skip resolver: " ++ show au]
showInterval :: (Integer, Integer) -> String
showInterval (n, 1) = show n ++ "..*"
showInterval (n, m) = show n ++ ".." ++ show m
claferIRXSD :: String
claferIRXSD = Language.Clafer.Generator.Schema.xsd
keyWords :: [String]
keyWords = ["ref","parent","abstract", "else", "in", "no", "opt", "xor", "all", "enum", "lone", "not", "or", "disj", "extends", "mux", "one", "some"]