diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,7 @@ +**Clafer Version 0.3.6 released on May 23, 2014** + +[Release](https://github.com/gsdlab/clafer/pull/48) + **Clafer Version 0.3.5 released on January 20, 2014** [Release](https://github.com/gsdlab/clafer/pull/44) diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -1,26 +1,24 @@ SRC_DIR := src TEST_DIR := test TOOL_DIR := tools -UNAME := $(shell uname -o | tr "A-Z" "a-z") -ifeq ($(UNAME), cygwin) - GPLK_LIBS_INCLUDES := --extra-include-dirs=$(glpk)/src --extra-include-dirs=$(glpk)/src/amd --extra-include-dirs=$(glpk)/src/colamd --extra-include-dirs=$(glpk)/src/minisat --extra-include-dirs=$(glpk)/src/zlib --extra-lib-dirs=$(glpk)/w32 -endif -ifeq ($(UNAME), windows) - GPLK_LIBS_INCLUDES := --extra-include-dirs=$(glpk)/src --extra-include-dirs=$(glpk)/src/amd --extra-include-dirs=$(glpk)/src/colamd --extra-include-dirs=$(glpk)/src/minisat --extra-include-dirs=$(glpk)/src/zlib --extra-lib-dirs=$(glpk)/w32 -endif -ifeq ($(UNAME), msys) - GPLK_LIBS_INCLUDES := --extra-include-dirs=$(glpk)/src --extra-include-dirs=$(glpk)/src/amd --extra-include-dirs=$(glpk)/src/colamd --extra-include-dirs=$(glpk)/src/minisat --extra-include-dirs=$(glpk)/src/zlib --extra-lib-dirs=$(glpk)/w32 -endif -ifeq ($(UNAME), darwin) - MAC_USR_LIB := --extra-lib-dir=/usr/lib +ifeq ($(OS),Windows_NT) + GPLK_LIBS_INCLUDES := --extra-include-dirs=$(glpk)/src --extra-include-dirs=$(glpk)/src/amd --extra-include-dirs=$(glpk)/src/colamd --extra-include-dirs=$(glpk)/src/minisat --extra-include-dirs=$(glpk)/src/zlib --extra-lib-dirs=$(glpk)/w32 +else + UNAME_S := $(shell uname -s) + ifeq ($(UNAME_S),Darwin) + MAC_USR_LIB := --extra-lib-dir=/opt/local/lib --extra-include-dir=/opt/local/include/ + endif endif all: build -build: - $(MAKE) -C $(TOOL_DIR) +init: + cabal sandbox init --sandbox=../.clafertools-cabal-sandbox cabal install --only-dependencies $(GPLK_LIBS_INCLUDES) $(MAC_USR_LIB) + +build: + $(MAKE) -C $(TOOL_DIR) cabal configure cabal build @@ -65,8 +63,6 @@ .PHONY : test test: - cabal configure --enable-tests - cabal build cabal test $(MAKE) -C $(TEST_DIR) test diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,7 +1,7 @@ Clafer ====== -v0.3.5.1 +v0.3.6 [Clafer](http://clafer.org) is a general-purpose lightweight structural modeling language developed by [GSD Lab](http://gsd.uwaterloo.ca/), [University of Waterloo](http://uwaterloo.ca), and @@ -27,13 +27,18 @@ It translates models in Clafer to other formats (e.g. Alloy, XML, Python, JS, HTML, DOT) to allow for reasoning and processing with existing tools (Alloy Analyzer, Choco3, and Z3 SMT solver). Currently, the compiler is used by -Clafer Instance Generator ([ClaferIG](https://github.com/gsdlab/claferIG)), -Clafer Integrated Development Environment ([ClaferIDE](https://github.com/gsdlab/claferIDE)), -Clafer Configurator ([ClaferConfigurator](https://github.com/gsdlab/ClaferConfigurator)), -Clafer Multi-Objective Optimizer ([ClaferMOO](https://github.com/gsdlab/ClaferMooStandalone)) and -[Visualizer](https://github.com/gsdlab/ClaferMooVisualizer), and -Clafer Wiki ([ClaferWiki](https://github.com/gsdlab/claferwiki)). +* Backends + * Alloy-based Instance Generator ([ClaferIG](https://github.com/gsdlab/claferIG)), + * Alloy-based Multi-Objective Optimizer ([ClaferMOO](https://github.com/gsdlab/ClaferMooStandalone)), + * Choco3-based Instance Generator and Multi-Objective Optimizer ([ChocoIG](https://github.com/gsdlab/claferIG)), and + * Z3-based Instance Generator and Multi-Objective Optimizer ([ClaferZ3](https://github.com/gsdlab/claferIG)), +* Frontends + * Clafer Integrated Development Environment ([ClaferIDE](https://github.com/gsdlab/claferIDE)), + * Clafer Configurator ([ClaferConfigurator](https://github.com/gsdlab/ClaferConfigurator)), + * Multi-Objective [Visualizer and Explorer](https://github.com/gsdlab/ClaferMooVisualizer), and + * Clafer Wiki ([ClaferWiki](https://github.com/gsdlab/claferwiki)). + Contributors ------------ @@ -59,7 +64,7 @@ Optional: -* [Java Platform (JDK)](http://www.oracle.com/technetwork/java/javase/downloads/index.html) v6+, 32bit +* [Java Platform (JDK)](http://www.oracle.com/technetwork/java/javase/downloads/index.html) v7+, 32bit * needed only for running XML output validation * [Alloy4.1 and/or Alloy4.2](http://alloy.mit.edu/alloy/download.html) * needed only for Alloy output validation @@ -82,13 +87,14 @@ * inside the `w32` folder, copy `glpk_4_52.dll` to `glpk.dll` so that it can be found when building Haskell package `glpk-hs` * from `w32` folder, copy `glpk_4_52.dll` to `\AppData\Roaming\cabal\bin` -On Mac only +On Mac + 1. install GPLK 4.52 from [MacPorts](http://www.macports.org/) * execute `sudo port install glpk +universal` ### Installation from binaries -Binary distributions of the release 0.3.5.1 of Clafer Tools for Windows, Mac, and Linux, +Binary distributions of the release 0.3.6 of Clafer Tools for Windows, Mac, and Linux, can be downloaded from [Clafer Tools - Binary Distributions](http://http://gsd.uwaterloo.ca/clafer-tools-binary-distributions). @@ -101,12 +107,13 @@ * [The Haskell Platform](http://hackage.haskell.org/platform/) v2013.2.0.0 -Clafer is now available on [Hackage](http://hackage.haskell.org/package/clafer-0.3.5.1/) and it can be installed using +Clafer is now available on [Hackage](http://hackage.haskell.org/package/clafer-0.3.6/) and it can be installed using 1. `cabal update` 2. `cabal install clafer` -3. to automatically download Alloy jars - * execute `make` in `clafer-0.3.5.1/tools` inside the Cabal's library folder +3. `cd ` (`C:\Users\\AppData\Roaming\cabal\i386-windows-ghc-7.6.3\clafer-0.3.6` on Windows or `.cabal/share/x86_64-linux-ghc-7.6.3/clafer-0.3.6/` on Linux) +4. to automatically download Alloy jars + * execute `make` in `tools` On Windows @@ -117,16 +124,19 @@ Dependencies * [The Haskell Platform](http://hackage.haskell.org/platform/) v2013.2.0.0 + * Cabal >= 1.18 * [Alloy4.1 and/or Alloy4.2](http://alloy.mit.edu/alloy/download.html) - * downloaded automatically during build + * downloaded automatically during the build * [Git](http://git-scm.com/) On Windows * [MinGW+MSYS](http://mingw.org) - * since the Haskell Platform already contains MinGW, you may choose to install MinGW+MSYS to the same location, e.g., `c:\...\HaskellPlatform\2013.2.0.0` - * add the `bin` folders of MinGW (`MinGW\bin`) and MSYS (`MinGW\MSYS\1.0\bin`) to your system path - * `unzip` will be automatically installed + * download [mingw-get-setup.exe](http://sourceforge.net/projects/mingw/files/Installer/mingw-get/) + * since the Haskell Platform already contains MinGW, only install MSYS. Installing another MinGW causes problems as it contains different versions of tools as compared to the MinGW in the Haskell Platform + * choose the existing MinGW location, e.g., `c:\...\HaskellPlatform\2013.2.0.0\MinGw` + * ensure `wget` and `unzip` are selected to be installed + * add the `bin` folder of MSYS (`MinGW\MSYS\1.0\bin`) to your system path #### Important: Branches must correspond @@ -145,17 +155,17 @@ 4. in `/clafer`, execute * `cabal update` 5. On Linux and Mac execute + * `make init` * `make` 6. On Windows (in MinGW), execute - * `make glpk="/c/"` + * `make glpk=/c/` ### Installation 1. On Linux and Mac execute * `make install to=` 2. On Windows (in MinGW), execute - * `make glpk="/c/" to=/c/` -3. add the `` to your system PATH + * `make glpk=/c/ to=/c/Users//AppData/Roaming/cabal/bin` #### Note: > On Windows, use `/` with the `make` command instead of `\`. @@ -175,7 +185,7 @@ (As printed by `clafer --help`) ``` -Clafer v0.3.5.1 +Clafer 0.3.6 clafer [OPTIONS] [FILE] @@ -202,7 +212,8 @@ -l --no-layout Don't resolve off-side rule layout. --nl --new-layout Use new fast layout resolver (experimental). - -c --check-duplicates Check duplicated clafer names. + -c --check-duplicates Check duplicated clafer names in + the entire model. -f --skip-resolver Skip name resolution. -k --keep-unused Keep uninstantated abstract clafers ('alloy' and 'alloy42' modes only). @@ -300,7 +311,7 @@ ========== * See [language's website](http://clafer.org) for news, technical reports and more * Check out a [Clafer tutorial](http://t3-necsis.cs.uwaterloo.ca:8091/Tutorial/Intro) - * Try a live instance of [ClaferWiki](http://t3-necsis.cs.uwaterloo.ca:8091) + * Try a live instance of [ClaferWiki](http://t3-necsis.cs.uwaterloo.ca:8091) which contains a repository of models for various applications * Try a live instance of [ClaferIDE](http://t3-necsis.cs.uwaterloo.ca:8094) * Try a live instance of [ClaferConfigurator](http://t3-necsis.cs.uwaterloo.ca:8093) * Try a live instance of [ClaferMooVisualizer](http://t3-necsis.cs.uwaterloo.ca:8092) diff --git a/clafer.cabal b/clafer.cabal --- a/clafer.cabal +++ b/clafer.cabal @@ -1,5 +1,5 @@ Name: clafer -Version: 0.3.5.1 +Version: 0.3.6 Synopsis: clafer compiles Clafer models to other formats, such as Alloy, XML, HTML, Dot. Description: Clafer is a general purpose, lightweight, structural modeling language developed at GSD Lab, University of Waterloo. Lightweight modeling aims at improving the understanding of the problem domain in the early stages of software development and determining the requirements with fewer defects. Clafer's goal is to make modeling more accessible to a wider range of users and domains. The tool provides a reference language implementation. It translates models to other formats (e.g. Alloy, XML) to allow for reasoning with existing tools. Homepage: http://clafer.org @@ -10,7 +10,7 @@ Stability: Experimental Category: Model Build-type: Simple -Cabal-version: >= 1.16 +Cabal-version: >= 1.18 data-files: README.md, CHANGES.md, logo.pdf, @@ -34,7 +34,7 @@ main-is: clafer.hs build-depends: array >= 0.4.0.1, base >= 4.6.0.1 && < 5, - containers >= 0.4.2.1, + containers >= 0.5.0.0, directory >= 1.2.0.1, filepath >= 1.3.0.1, process >= 1.1.0.2, @@ -42,24 +42,27 @@ HUnit >= 1.2.5.2, mtl >= 2.1.2, parsec >= 3.1.3, - QuickCheck >= 2.5.1.1, + QuickCheck >= 2.6, transformers >= 0.3.0.0, - data-stringmap >= 0.9.1, + data-stringmap >= 1.0.1.1, + aeson >= 0.7.0.2, json-builder >= 0.3, - string-conversions >= 0.3, - cmdargs >= 0.10.5, + lens >= 4.1.1, + string-conversions >= 0.3.0.2, + cmdargs >= 0.10.7, executable-path >= 0.0.3, glpk-hs >= 0.3.4, - HaXml >= 1.24, + HaXml == 1.24, MaybeT >= 0.1.2, split >= 0.2.2, - test-framework >= 0.8, - test-framework-hunit >= 0.3.0, - test-framework-quickcheck2 >= 0.3.0.1, + test-framework >= 0.8.0.3, + test-framework-hunit >= 0.3.0.1, + test-framework-quickcheck2 >= 0.3.0.2, test-framework-th >= 0.2.4, + text >= 0.11.3.1, - clafer == 0.3.5.1 + clafer == 0.3.6 hs-source-dirs: src other-modules: Paths_clafer @@ -72,7 +75,7 @@ RankNTypes build-depends: array >= 0.4.0.1, base >= 4.6.0.1 && < 5, - containers >= 0.4.2.1, + containers >= 0.5.0.0, directory >= 1.2.0.1, filepath >= 1.3.0.1, process >= 1.1.0.2, @@ -80,22 +83,25 @@ HUnit >= 1.2.5.2, mtl >= 2.1.2, parsec >= 3.1.3, - QuickCheck >= 2.5.1.1, + QuickCheck >= 2.6, transformers >= 0.3.0.0, - data-stringmap >= 0.9.1, + data-stringmap >= 1.0.1.1, + aeson >= 0.7.0.2, json-builder >= 0.3, - string-conversions >= 0.3, - cmdargs >= 0.10.5, + lens >= 4.1.1, + string-conversions >= 0.3.0.2, + cmdargs >= 0.10.7, executable-path >= 0.0.3, glpk-hs >= 0.3.4, - HaXml >= 1.24, + HaXml == 1.24, MaybeT >= 0.1.2, split >= 0.2.2, - test-framework >= 0.8, - test-framework-hunit >= 0.3.0, - test-framework-quickcheck2 >= 0.3.0.1, - test-framework-th >= 0.2.4 + test-framework >= 0.8.0.3, + test-framework-hunit >= 0.3.0.1, + test-framework-quickcheck2 >= 0.3.0.2, + test-framework-th >= 0.2.4, + text >= 0.11.3.1 hs-source-dirs: src ghc-options: -Wall -fno-warn-unused-do-bind -fno-warn-orphans @@ -149,7 +155,7 @@ build-depends: array >= 0.4.0.1, base >= 4.6.0.1 && < 5, - containers >= 0.4.2.1, + containers >= 0.5.0.0, directory >= 1.2.0.1, filepath >= 1.3.0.1, process >= 1.1.0.2, @@ -157,29 +163,33 @@ HUnit >= 1.2.5.2, mtl >= 2.1.2, parsec >= 3.1.3, - QuickCheck >= 2.5.1.1, + QuickCheck >= 2.6, transformers >= 0.3.0.0, - data-stringmap >= 0.9.1, + data-stringmap >= 1.0.1.1, + aeson >= 0.7.0.2, json-builder >= 0.3, - string-conversions >= 0.3, - cmdargs >= 0.10.5, + lens >= 4.1.1, + string-conversions >= 0.3.0.2, + cmdargs >= 0.10.7, executable-path >= 0.0.3, glpk-hs >= 0.3.4, - HaXml >= 1.24, + HaXml == 1.24, MaybeT >= 0.1.2, split >= 0.2.2, - test-framework >= 0.8, - test-framework-hunit >= 0.3.0, - test-framework-quickcheck2 >= 0.3.0.1, + test-framework >= 0.8.0.3, + test-framework-hunit >= 0.3.0.1, + test-framework-quickcheck2 >= 0.3.0.2, test-framework-th >= 0.2.4, + text >= 0.11.3.1, - clafer == 0.3.5.1 + clafer == 0.3.6 - ghc-options -Wall -fno-warn-unused-do-bind -fno-warn-orphans + ghc-options: -Wall -fno-warn-unused-do-bind -fno-warn-orphans other-modules: Paths_clafer, Functions, Suite.Example, Suite.Positive, - Suite.Negative + Suite.Negative, + Suite.SimpleScopeAnalyser diff --git a/src/Language/Clafer.hs b/src/Language/Clafer.hs --- a/src/Language/Clafer.hs +++ b/src/Language/Clafer.hs @@ -258,10 +258,10 @@ 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 (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 "" @@ -278,15 +278,15 @@ do env <- getEnv (iModule, _, _) <- getIr - fragElems <- fragment (sortBy (comparing rnge) $ mDecls iModule) (frags env) + fragElems <- fragment (sortBy (comparing rnge) $ _mDecls iModule) (frags env) -- Assumes output mode is Alloy for now 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 + rnge (IEClafer IClafer{_cinPos = p}) = p + rnge IEConstraint{_cpexp = PExp{_inPos = p}} = p + rnge IEGoal{_cpexp = PExp{_inPos = p}} = p -- Groups IElements by their fragments. -- elems must be sorted by range. @@ -512,17 +512,18 @@ } deriving Show desugar :: Module -> IModule -desugar tree = desugarModule tree +desugar iModule = desugarModule iModule 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' +analyze args' iModule = do + liftError $ findDupModule args' iModule + let + au = allUnique iModule let args'' = args'{skip_resolver = au && (skip_resolver args')} - (rTree, genv) <- liftError $ resolveModule args'' dTree' + (rTree, genv) <- liftError $ resolveModule args'' iModule let tTree = transModule rTree return (optimizeModule args'' (tTree, genv), genv, au) diff --git a/src/Language/Clafer/ClaferArgs.hs b/src/Language/Clafer/ClaferArgs.hs --- a/src/Language/Clafer/ClaferArgs.hs +++ b/src/Language/Clafer/ClaferArgs.hs @@ -83,7 +83,7 @@ timeout_analysis = def &= help "Timeout for analysis.", no_layout = def &= help "Don't resolve off-side rule layout." &= name "l", new_layout = def &= help "Use new fast layout resolver (experimental)." &= name "nl", - check_duplicates = def &= help "Check duplicated clafer names." &= name "c", + check_duplicates = def &= help "Check duplicated clafer names in the entire model." &= name "c", skip_resolver = def &= help "Skip name resolution." &= name "f", keep_unused = def &= help "Keep uninstantated abstract clafers ('alloy' and 'alloy42' modes only)." &= name "k", no_stats = def &= help "Don't print statistics." &= name "s", @@ -134,12 +134,7 @@ model <- case file args' of "" -> hGetContents stdin f -> readFile f - let firstLine = case lines model of - [] -> "" - (s:_) -> s - let options = fromMaybe "" $ stripPrefix "//# OPTIONS " firstLine - let args'' = either (const args') (mergeArgs args' . cmdArgsValue) $ - process (cmdArgsMode clafer) $ Language.Clafer.SplitJoin.splitArgs options + let args'' = argsWithOPTIONS args' model -- Alloy should be the default mode but only if nothing else was specified -- cannot use [ Alloy ] as the default in the definition of `clafer :: ClaferArgs` since -- Alloy will always be a mode in addition to the other specified modes (it will become mandatory) @@ -147,6 +142,17 @@ then args''{mode = [ Alloy ]} else args'' return $ (args''', model) + +argsWithOPTIONS :: ClaferArgs -> String -> ClaferArgs +argsWithOPTIONS args' model = + let + firstLine = case lines model of + [] -> "" + (s:_) -> s + options = fromMaybe "" $ stripPrefix "//# OPTIONS " firstLine + in + either (const args') (mergeArgs args' . cmdArgsValue) $ + process (cmdArgsMode clafer) $ Language.Clafer.SplitJoin.splitArgs options defaultClaferArgs :: ClaferArgs defaultClaferArgs = ClaferArgs [ def ] True False 0 False False False False False False False False False "tools/" False False False False False False Simple False False False "" diff --git a/src/Language/Clafer/Common.hs b/src/Language/Clafer/Common.hs --- a/src/Language/Clafer/Common.hs +++ b/src/Language/Clafer/Common.hs @@ -48,19 +48,19 @@ type Ident = PosIdent getSuper :: IClafer -> String -getSuper = getSuperId.supers.super +getSuper = getSuperId._supers._super getSuperNoArr :: IClafer -> String getSuperNoArr clafer - | isOverlapping $ super clafer = "clafer" + | _isOverlapping $ _super clafer = "clafer" | otherwise = getSuper clafer getSuperId :: [PExp] -> String -getSuperId = sident . Language.Clafer.Intermediate.Intclafer.exp . head +getSuperId = _sident . Language.Clafer.Intermediate.Intclafer._exp . head isEqClaferId :: String -> IClafer -> Bool -isEqClaferId = flip $ (==).uid +isEqClaferId = flip $ (==)._uid idToPExp :: String -> Span -> String -> String -> Bool -> PExp idToPExp pid' pos modids id' isTop' = PExp (Just $ TClafer [id']) pid' pos (IClaferId modids id' isTop') @@ -126,7 +126,7 @@ findHierarchy sFun clafers clafer | sFun clafer == "clafer" = [clafer] | otherwise = if clafer `elem` superClafers - then error $ "Inheritance hierarchy contains a cycle: line " ++ (show $ cinPos clafer) + then error $ "Inheritance hierarchy contains a cycle: line " ++ (show $ _cinPos clafer) else clafer : superClafers where superClafers = unfoldr (\c -> find (isEqClaferId $ sFun c) clafers >>= @@ -145,7 +145,7 @@ toNodeShallow :: IClafer -> (IClafer, [IClafer]) -toNodeShallow = apply (getSubclafers.elements) +toNodeShallow = apply (getSubclafers._elements) getSubclafers :: [IElement] -> [IClafer] diff --git a/src/Language/Clafer/Front/Absclafer.hs b/src/Language/Clafer/Front/Absclafer.hs --- a/src/Language/Clafer/Front/Absclafer.hs +++ b/src/Language/Clafer/Front/Absclafer.hs @@ -1,5 +1,10 @@ +{-# LANGUAGE DeriveDataTypeable #-} + -- | Abstract syntax of the Clafer language. module Language.Clafer.Front.Absclafer where + +import Data.Data + noSpan :: Span noSpan = Span noPos noPos noPos :: Pos @@ -270,10 +275,10 @@ data Pos = Pos Integer Integer | PosPos Span Integer Integer - deriving (Eq,Ord,Show) + deriving (Eq,Ord,Show,Data,Typeable) data Span = Span Pos Pos | PosSpan Span Pos Pos - deriving (Eq,Ord,Show) + deriving (Eq,Ord,Show,Data,Typeable) diff --git a/src/Language/Clafer/Generator/Alloy.hs b/src/Language/Clafer/Generator/Alloy.hs --- a/src/Language/Clafer/Generator/Alloy.hs +++ b/src/Language/Clafer/Generator/Alloy.hs @@ -22,14 +22,17 @@ -} -- | Generates Alloy4.1 or 4.2 code for a Clafer model module Language.Clafer.Generator.Alloy where + +import Control.Lens hiding (elements, mapping) +import Control.Monad.State import Data.List import Data.Maybe -import Control.Monad.State import Language.Clafer.Common import Language.Clafer.ClaferArgs import Language.Clafer.Front.Absclafer -import Language.Clafer.Intermediate.Intclafer +import Language.Clafer.Intermediate.Intclafer hiding (exp) +-- import qualified Language.Clafer.Intermediate.Intclafer as I (exp) -- | representation of strings in chunks (for line/column numbering) data Concat = CString String | Concat { @@ -90,13 +93,13 @@ genModule :: ClaferArgs -> (IModule, GEnv) -> [(UID, Integer)] -> (Result, [(Span, IrTrace)]) genModule claferargs (imodule, _) scopes = (flatten output, filter ((/= NoTrace) . snd) $ mapLineCol output) where - output = header claferargs scopes +++ (cconcat $ map (genDeclaration claferargs) (mDecls imodule)) +++ + output = header claferargs scopes +++ (cconcat $ map (genDeclaration claferargs) (_mDecls imodule)) +++ if ((not $ skip_goals claferargs) && length goals_list > 0) then CString "objectives o_global {\n" +++ (cintercalate (CString ",\n") goals_list) +++ CString "\n}" else CString "" where - goals_list = filterNull (map (genDeclarationGoalsOnly claferargs) (mDecls imodule)) + goals_list = filterNull (map (genDeclarationGoalsOnly claferargs) (_mDecls imodule)) header :: ClaferArgs -> [(UID, Integer)] -> Concat header args scopes = CString $ unlines @@ -170,27 +173,27 @@ where clafer' = transPrimitive oClafer children' = cconcat $ filterNull $ map - (genClafer claferargs ((uid clafer') : resPath)) $ - getSubclafers $ elements clafer' + (genClafer claferargs ((_uid clafer') : resPath)) $ + getSubclafers $ _elements clafer' cardFact | null resPath && (null $ flatten $ genOptCard clafer') = - case genCard (uid clafer') $ card clafer' of + case genCard (_uid clafer') $ _card clafer' of CString "set" -> CString "" c -> mkFact c | otherwise = CString "" transPrimitive :: IClafer -> IClafer -transPrimitive clafer' = clafer'{super = toOverlapping $ super clafer'} +transPrimitive = super %~ toOverlapping where - toOverlapping x@(ISuper _ [PExp _ _ _ (IClaferId _ id' _)]) - | isPrimitive id' = x{isOverlapping = True} - | otherwise = x - toOverlapping x = x + toOverlapping x@(ISuper _ [PExp _ _ _ (IClaferId _ id' _)]) + | isPrimitive id' = x{_isOverlapping = True} + | otherwise = x + toOverlapping x = x claferDecl :: IClafer -> Concat -> Concat claferDecl c rest = cconcat [genOptCard c, - CString $ genAbstract $ isAbstract c, CString "sig ", - Concat NoTrace [CString $ uid c, genExtends $ super c, CString "\n", rest]] + CString $ genAbstract $ _isAbstract c, CString "sig ", + Concat NoTrace [CString $ _uid c, genExtends $ _super c, CString "\n", rest]] where genAbstract isAbs = if isAbs then "abstract " else "" genExtends (ISuper False [PExp _ _ _ (IClaferId _ "clafer" _)]) = CString "" @@ -200,10 +203,10 @@ genOptCard :: IClafer -> Concat genOptCard c - | glCard' `elem` ["lone", "one", "some"] = cardConcat (uid c) False [CString glCard'] +++ (CString " ") + | glCard' `elem` ["lone", "one", "some"] = cardConcat (_uid c) False [CString glCard'] +++ (CString " ") | otherwise = CString "" where - glCard' = genIntervalCrude $ glCard c + glCard' = genIntervalCrude $ _glCard c -- ----------------------------------------------------------------------------- @@ -212,22 +215,22 @@ -- adds parent relation -- 29/March/2012 Rafael Olaechea: ref is now prepended with clafer name to be able to refer to it from partial instances. genRelations :: ClaferArgs -> IClafer -> [Concat] -genRelations claferargs c = maybeToList r ++ (map mkRel $ getSubclafers $ elements c) +genRelations claferargs c = maybeToList r ++ (map mkRel $ getSubclafers $ _elements c) where - r = if isOverlapping $ super c + r = if _isOverlapping $ _super c then - Just $ Concat NoTrace [CString $ genRel (if (noalloyruncommand claferargs) then (uid c ++ "_ref") else "ref") - c {card = Just (1, 1)} $ + Just $ Concat NoTrace [CString $ genRel (if (noalloyruncommand claferargs) then (_uid c ++ "_ref") else "ref") + c {_card = Just (1, 1)} $ flatten $ refType claferargs c] else Nothing - mkRel c' = Concat NoTrace [CString $ genRel (genRelName $ uid c') c' $ uid c'] + mkRel c' = Concat NoTrace [CString $ genRel (genRelName $ _uid c') c' $ _uid c'] genRelName :: String -> String genRelName name = "r_" ++ name genRel :: String -> IClafer -> String -> String -genRel name c rType = genAlloyRel name (genCardCrude $ card c) rType' +genRel name c rType = genAlloyRel name (genCardCrude $ _card c) rType' where rType' = if isPrimitive rType then "Int" else rType @@ -235,7 +238,7 @@ genAlloyRel name card' rType = concat [name, " : ", card', " ", rType] refType :: ClaferArgs -> IClafer -> Concat -refType claferargs c = cintercalate (CString " + ") $ map ((genType claferargs).getTarget) $ supers $ super c +refType claferargs c = cintercalate (CString " + ") $ map ((genType claferargs).getTarget) $ _supers $ _super c getTarget :: PExp -> PExp @@ -245,7 +248,7 @@ genType :: ClaferArgs -> PExp -> Concat genType claferargs x@(PExp _ _ _ y@(IClaferId _ _ _)) = genPExp claferargs [] - x{Language.Clafer.Intermediate.Intclafer.exp = y{isTop = True}} + x{_exp = y{_isTop = True}} genType m x = genPExp m [] x @@ -255,14 +258,14 @@ -- a = NUMBER do all x : a | x = NUMBER (otherwise alloy sums a set) genConstraints :: ClaferArgs -> [String] -> IClafer -> [Concat] genConstraints cargs resPath c = (genParentConst resPath c) : - (genGroupConst c) : genPathConst cargs (if (noalloyruncommand cargs) then (uid c ++ "_ref") else "ref") resPath c : constraints + (genGroupConst c) : genPathConst cargs (if (noalloyruncommand cargs) then (_uid c ++ "_ref") else "ref") resPath c : constraints where - constraints = map genConst $ elements c + constraints = map genConst $ _elements c genConst x = case x of - IEConstraint _ pexp -> genPExp cargs ((uid c) : resPath) pexp + IEConstraint _ pexp -> genPExp cargs ((_uid c) : resPath) pexp IEClafer c' -> - if genCardCrude (card c') `elem` ["one", "lone", "some"] - then CString "" else mkCard ({- do not use the genRelName as the constraint name -} uid c') False (genRelName $ uid c') $ fromJust (card c') + if genCardCrude (_card c') `elem` ["one", "lone", "some"] + then CString "" else mkCard ({- do not use the genRelName as the constraint name -} _uid c') False (genRelName $ _uid c') $ fromJust (_card c') IEGoal _ _ -> error "getConst function from Alloy generator was given a Goal, this function should only be given a Constrain or Clafer" -- This should never happen -- optimization: if only boolean features then the parent is unique @@ -279,25 +282,25 @@ -- should be added to cases when cyclic containment occurs -- , " && no iden & @", rel, " && no ~@", rel, " & @", rel] where - rel = genRelName $ uid c - glCard' = genIntervalCrude $ glCard c + rel = genRelName $ _uid c + glCard' = genIntervalCrude $ _glCard c genGroupConst :: IClafer -> Concat genGroupConst clafer' | null children' || flatten card' == "" = CString "" | otherwise = cconcat [CString "let children = ", brArg id $ CString children', CString" | ", card'] where - children' = intercalate " + " $ map (genRelName.uid) $ - getSubclafers $ elements clafer' - card' = mkCard (uid clafer') True "children" $ interval $ fromJust $ gcard $ clafer' + children' = intercalate " + " $ map (genRelName._uid) $ + getSubclafers $ _elements clafer' + card' = mkCard (_uid clafer') True "children" $ _interval $ fromJust $ _gcard $ clafer' mkCard :: String -> Bool -> String -> (Integer, Integer) -> Concat -mkCard constraintName group' element crd +mkCard constraintName group' element' crd | crd' == "set" || crd' == "" = CString "" - | crd' `elem` ["one", "lone", "some"] = CString $ crd' ++ " " ++ element + | crd' `elem` ["one", "lone", "some"] = CString $ crd' ++ " " ++ element' | otherwise = interval' where - interval' = genInterval constraintName group' element crd + interval' = genInterval constraintName group' element' crd crd' = flatten $ interval' -- generates expression for references that point to expressions (not single clafers) @@ -306,14 +309,14 @@ | isRefPath c = cconcat [CString name, CString " = ", cintercalate (CString " + ") $ map ((brArg id).(genPExp claferargs resPath)) $ - supers $ super c] + _supers $ _super c] | otherwise = CString "" isRefPath :: IClafer -> Bool -isRefPath c = (isOverlapping $ super c) && +isRefPath c = (c ^. super . isOverlapping) && ((length s > 1) || (not $ isSimplePath s)) where - s = supers $ super c + s = _supers $ _super c isSimplePath :: [PExp] -> Bool isSimplePath [PExp _ _ _ (IClaferId _ _ _)] = True @@ -326,7 +329,7 @@ genCard :: String -> Maybe Interval -> Concat -genCard element crd = genInterval element False element $ fromJust crd +genCard element' crd = genInterval element' False element' $ fromJust crd genCardCrude :: Maybe Interval -> String genCardCrude crd = genIntervalCrude $ fromJust crd @@ -340,7 +343,7 @@ genInterval :: String -> Bool -> String -> Interval -> Concat -genInterval constraintName group' element x = case x of +genInterval constraintName group' element' x = case x of (1, 1) -> cardConcat constraintName group' [CString "one"] (0, 1) -> cardConcat constraintName group' [CString "lone"] (1, -1) -> cardConcat constraintName group' [CString "some"] @@ -352,10 +355,10 @@ (Nothing, Just c2) -> c2 (Nothing, Nothing) -> undefined where - s1 = if n == 0 then Nothing else Just $ cardLowerConcat constraintName group' [CString $ concat [show n, " <= #", element]] + s1 = if n == 0 then Nothing else Just $ cardLowerConcat constraintName group' [CString $ concat [show n, " <= #", element']] s2 = do - result <- genExInteger element x exinteger + result <- genExInteger element' x exinteger return $ cardUpperConcat constraintName group' [CString result] @@ -372,9 +375,9 @@ genExInteger :: String -> Interval -> Integer -> Maybe Result -genExInteger element (y,z) x = - if (y==0 && z==0) then Just $ concat ["#", element, " = ", "0"] else - if x == -1 then Nothing else Just $ concat ["#", element, " <= ", show x] +genExInteger element' (y,z) x = + if (y==0 && z==0) then Just $ concat ["#", element', " = ", "0"] else + if x == -1 then Nothing else Just $ concat ["#", element', " <= ", show x] -- ----------------------------------------------------------------------------- @@ -422,12 +425,12 @@ -- See http://gsd.uwaterloo.ca:8888/question/461/new-translation-of-negative-number-x-into-0-x-is. transformExp :: IExp -> IExp transformExp (IFunExp op' (e1:_)) - | op' == iMin = IFunExp iMul [PExp (iType e1) "" noSpan $ IInt (-1), e1] + | op' == iMin = IFunExp iMul [PExp (_iType e1) "" noSpan $ IInt (-1), e1] transformExp x@(IFunExp op' exps'@(e1:e2:_)) | op' == iXor = IFunExp iNot [PExp (Just TBoolean) "" noSpan (IFunExp iIff exps')] | op' == iJoin && isClaferName' e1 && isClaferName' e2 && getClaferName e1 == this && head (getClaferName e2) == '~' = - IFunExp op' [e1{iType = Just $ TClafer []}, e2] + IFunExp op' [e1{_iType = Just $ TClafer []}, e2] | otherwise = x transformExp x = x @@ -506,14 +509,14 @@ adjustNav :: [String] -> IExp -> (IExp, [String]) adjustNav resPath x@(IFunExp op' (pexp0:pexp:_)) | op' == iJoin = (IFunExp iJoin - [pexp0{Language.Clafer.Intermediate.Intclafer.exp = iexp0}, - pexp{Language.Clafer.Intermediate.Intclafer.exp = iexp}], path') + [pexp0{_exp = iexp0}, + pexp{_exp = iexp}], path') | otherwise = (x, resPath) where - (iexp0, path) = adjustNav resPath (Language.Clafer.Intermediate.Intclafer.exp pexp0) - (iexp, path') = adjustNav path (Language.Clafer.Intermediate.Intclafer.exp pexp) + (iexp0, path) = adjustNav resPath (_exp pexp0) + (iexp, path') = adjustNav path (_exp pexp) adjustNav resPath x@(IClaferId _ id' _) - | id' == parent = (x{sident = "~@" ++ (genRelName $ head resPath)}, tail resPath) + | id' == parent = (x{_sident = "~@" ++ (genRelName $ head resPath)}, tail resPath) | otherwise = (x, resPath) adjustNav _ _ = error "Function adjustNav Expect a IFunExp or IClaferID as one of it's argument but it was given a differnt IExp" --This should never happen diff --git a/src/Language/Clafer/Generator/Choco.hs b/src/Language/Clafer/Generator/Choco.hs --- a/src/Language/Clafer/Generator/Choco.hs +++ b/src/Language/Clafer/Generator/Choco.hs @@ -17,29 +17,29 @@ -- | Choco 3 code generation genCModule :: ClaferArgs -> (IModule, GEnv) -> [(UID, Integer)] -> Result -genCModule _ (IModule{mDecls}, _) scopes = +genCModule _ (IModule{_mDecls}, _) scopes = genScopes ++ "\n" ++ (genAbstractClafer =<< abstractClafers) ++ (genConcreteClafer =<< concreteClafers) ++ (genRefClafer =<< clafers) - ++ (genTopConstraint =<< mDecls) + ++ (genTopConstraint =<< _mDecls) ++ (genConstraint =<< clafers) - ++ (genGoal =<< mDecls) + ++ (genGoal =<< _mDecls) where root :: IClafer - root = IClafer noSpan False Nothing "root" "root" (ISuper False [PExp Nothing "" noSpan $ IClaferId "clafer" "clafer" True]) (Just (1, 1)) (0, 0) mDecls + root = IClafer noSpan False Nothing "root" "root" (ISuper False [PExp Nothing "" noSpan $ IClaferId "clafer" "clafer" True]) (Just (1, 1)) (0, 0) _mDecls - toplevelClafers = mapMaybe iclafer mDecls + toplevelClafers = mapMaybe iclafer _mDecls -- The sort is so that we encounter sub clafers before super clafers when abstract clafers extend other abstract clafers - abstractClafers = sortBy (comparing $ length . supersOf . uid) $ filter isAbstract toplevelClafers + abstractClafers = sortBy (comparing $ length . supersOf . _uid) $ filter _isAbstract toplevelClafers parentChildMap = childClafers root clafers = snd <$> parentChildMap - claferUids = uid <$> clafers + claferUids = _uid <$> clafers concreteClafers = filter isNotAbstract clafers -- minusRoot = filter ((/= "root") . uid) - claferWithUid u = fromMaybe (error $ "claferWithUid: \"" ++ u ++ "\" is not a clafer") $ find ((== u) . uid) clafers + claferWithUid u = fromMaybe (error $ "claferWithUid: \"" ++ u ++ "\" is not a clafer") $ find ((== u) . _uid) clafers prims = ["int", "integer", "string", "real"] @@ -53,11 +53,11 @@ -- superHierarchyOf u = u : supersOf u superOf u = - case super $ claferWithUid u of - ISuper False [PExp{exp = IClaferId{sident}}] - | sident == "clafer" -> Nothing - | sident `elem` prims -> Nothing - | otherwise -> Just sident + case _super $ claferWithUid u of + ISuper False [PExp{_exp = IClaferId{_sident}}] + | _sident == "clafer" -> Nothing + | _sident `elem` prims -> Nothing + | otherwise -> Just _sident _ -> Nothing {- superWithRef u = @@ -66,22 +66,22 @@ _ -> u ++ " does not inherit a ref" -} refOf u = - case super $ claferWithUid u of - ISuper True [PExp{exp = IClaferId{sident}}] -> Just sident - ISuper False [PExp{exp = IClaferId{sident}}] - | sident == "int" -> Just "integer" - | sident `elem` prims -> Just sident + case _super $ claferWithUid u of + ISuper True [PExp{_exp = IClaferId{_sident}}] -> Just _sident + ISuper False [PExp{_exp = IClaferId{_sident}}] + | _sident == "int" -> Just "integer" + | _sident `elem` prims -> Just _sident | otherwise -> Nothing _ -> Nothing -- All clafers that inherit u {- subOf :: String -> [String] - subOf u = [uid | IClafer{uid} <- clafers, Just u == superOf uid] + subOf u = [uid | IClafer{_uid} <- clafers, Just u == superOf uid] subClaferOf :: String -> [IClafer] subClaferOf = map claferWithUid . subOf subOffsets :: [(String, String, Integer)] - subOffsets = [(uid, sub, off) | IClafer{uid} <- clafers, let subs = subOf uid, (sub, off) <- zip subs $ offsets subs] + subOffsets = [(uid, sub, off) | IClafer{_uid} <- clafers, let subs = subOf uid, (sub, off) <- zip subs $ offsets subs] subOffsetOf :: String -> Integer subOffsetOf sub = trd3 $ fromMaybe (error $ "subOffsetOf: " ++ sub) $ find ((== sub) . snd3) subOffsets @@ -90,7 +90,7 @@ offsets = scanl (flip $ (+) . scopeOf) 0 -} - parentOf u = fst $ fromMaybe (error $ "parentOf: \"" ++ u ++ "\" is not a clafer") $ find ((== u) . uid . snd) parentChildMap + parentOf u = fst $ fromMaybe (error $ "parentOf: \"" ++ u ++ "\" is not a clafer") $ find ((== u) . _uid . snd) parentChildMap {- parentClaferOf = claferWithUid . parentOf -- Direct childrens childrenOf = map uid . childrenClaferOf @@ -116,14 +116,14 @@ ++ "defaultScope(1);\n" ++ "intRange(-" ++ show (2 ^ (bitwidth - 1)) ++ ", " ++ show (2 ^ (bitwidth - 1) - 1) ++ ");\n" where - scopeMap = [uid ++ ":" ++ show scope | (uid, scope) <- scopes] + scopeMap = [uid' ++ ":" ++ show scope | (uid', scope) <- scopes, uid' /= "int"] genConcreteClafer :: IClafer -> Result - genConcreteClafer IClafer{uid, card = Just card, gcard = Just (IGCard _ gcard)} = - uid ++ " = " ++ constructor ++ "(\"" ++ uid ++ "\")" ++ prop "withCard" (genCard card) ++ prop "withGroupCard" (genCard gcard) ++ prop "extending" (superOf uid) ++ ";\n" + genConcreteClafer IClafer{_uid, _card = Just _card, _gcard = Just (IGCard _ _gcard)} = + _uid ++ " = " ++ constructor ++ "(\"" ++ _uid ++ "\")" ++ prop "withCard" (genCard _card) ++ prop "withGroupCard" (genCard _gcard) ++ prop "extending" (superOf _uid) ++ ";\n" where constructor = - case parentOf uid of + case parentOf _uid of "root" -> "Clafer" puid -> puid ++ ".addChild" @@ -134,54 +134,54 @@ genRefClafer :: IClafer -> Result - genRefClafer IClafer{uid} = - case (refOf uid, uid `elem` uniqueRefs) of - (Just target, True) -> uid ++ ".refToUnique(" ++ genTarget target ++ ");\n" - (Just target, False) -> uid ++ ".refTo(" ++ genTarget target ++ ");\n" + genRefClafer IClafer{_uid} = + case (refOf _uid, _uid `elem` uniqueRefs) of + (Just target, True) -> _uid ++ ".refToUnique(" ++ genTarget target ++ ");\n" + (Just target, False) -> _uid ++ ".refTo(" ++ genTarget target ++ ");\n" _ -> "" where genTarget "integer" = "Int" genTarget target = target genAbstractClafer :: IClafer -> Result - genAbstractClafer IClafer{uid, card = Just _} = - uid ++ " = Abstract(\"" ++ uid ++ "\")" ++ prop "extending" (superOf uid) ++ ";\n" - genAbstractClafer IClafer{uid, card = Nothing} = - uid ++ " = Abstract(\"" ++ uid ++ "\")" ++ prop "extending" (superOf uid) ++ ";\n" + genAbstractClafer IClafer{_uid, _card = Just _} = + _uid ++ " = Abstract(\"" ++ _uid ++ "\")" ++ prop "extending" (superOf _uid) ++ ";\n" + genAbstractClafer IClafer{_uid, _card = Nothing} = + _uid ++ " = Abstract(\"" ++ _uid ++ "\")" ++ prop "extending" (superOf _uid) ++ ";\n" -- Is a uniqueness constraint? If so, return the name of unique clafer isUniqueConstraint :: IExp -> Maybe String - isUniqueConstraint (IDeclPExp IAll [IDecl True [x, y] PExp{exp = IClaferId {sident}}] - PExp{exp = IFunExp "!=" [ - PExp{exp = IFunExp "." [PExp{exp = IClaferId{sident = xident}}, PExp{exp = IClaferId{sident = "ref"}}]}, - PExp{exp = IFunExp "." [PExp{exp = IClaferId{sident = yident}}, PExp{exp = IClaferId{sident = "ref"}}]}]}) - | x == xident && y == yident = return sident + isUniqueConstraint (IDeclPExp IAll [IDecl True [x, y] PExp{_exp = IClaferId{_sident}}] + PExp{_exp = IFunExp "!=" [ + PExp{_exp = IFunExp "." [PExp{_exp = IClaferId{_sident = xident}}, PExp{_exp = IClaferId{_sident = "ref"}}]}, + PExp{_exp = IFunExp "." [PExp{_exp = IClaferId{_sident = yident}}, PExp{_exp = IClaferId{_sident = "ref"}}]}]}) + | x == xident && y == yident = return _sident | otherwise = mzero - isUniqueConstraint (IDeclPExp IAll [IDecl True [x, y] PExp{exp = IFunExp "." [PExp{exp = IClaferId{sident = "this"}}, PExp{exp = IClaferId {sident}}]}] - PExp{exp = IFunExp "!=" [ - PExp{exp = IFunExp "." [PExp{exp = IClaferId{sident = xident}}, PExp{exp = IClaferId{sident = "ref"}}]}, - PExp{exp = IFunExp "." [PExp{exp = IClaferId{sident = yident}}, PExp{exp = IClaferId{sident = "ref"}}]}]}) - | x == xident && y == yident = return sident + isUniqueConstraint (IDeclPExp IAll [IDecl True [x, y] PExp{_exp = IFunExp "." [PExp{_exp = IClaferId{_sident = "this"}}, PExp{_exp = IClaferId{_sident}}]}] + PExp{_exp = IFunExp "!=" [ + PExp{_exp = IFunExp "." [PExp{_exp = IClaferId{_sident = xident}}, PExp{_exp = IClaferId{_sident = "ref"}}]}, + PExp{_exp = IFunExp "." [PExp{_exp = IClaferId{_sident = yident}}, PExp{_exp = IClaferId{_sident = "ref"}}]}]}) + | x == xident && y == yident = return _sident | otherwise = mzero isUniqueConstraint _ = mzero uniqueRefs :: [String] - uniqueRefs = mapMaybe isUniqueConstraint $ map exp $ mapMaybe iconstraint $ mDecls ++ (clafers >>= elements) + uniqueRefs = mapMaybe isUniqueConstraint $ map _exp $ mapMaybe iconstraint $ _mDecls ++ (clafers >>= _elements) genTopConstraint :: IElement -> Result genTopConstraint (IEConstraint _ pexp) - | isNothing $ isUniqueConstraint $ exp pexp = "Constraint(" ++ genConstraintPExp pexp ++ ");\n" + | isNothing $ isUniqueConstraint $ _exp pexp = "Constraint(" ++ genConstraintPExp pexp ++ ");\n" | otherwise = "" genTopConstraint _ = "" genConstraint :: IClafer -> Result - genConstraint IClafer{uid, elements} = - unlines [uid ++ ".addConstraint(" ++ genConstraintPExp c ++ ");" - | c <- filter (isNothing . isUniqueConstraint . exp) $ mapMaybe iconstraint elements] + genConstraint IClafer{_uid, _elements} = + unlines [_uid ++ ".addConstraint(" ++ genConstraintPExp c ++ ");" + | c <- filter (isNothing . isUniqueConstraint . _exp) $ mapMaybe iconstraint _elements] genGoal :: IElement -> Result - genGoal (IEGoal _ PExp{exp = IFunExp{op="max", exps=[expr]}}) = "max(" ++ genConstraintPExp expr ++ ");\n" - genGoal (IEGoal _ PExp{exp = IFunExp{op="min", exps=[expr]}}) = "min(" ++ genConstraintPExp expr ++ ");\n" + genGoal (IEGoal _ PExp{_exp = IFunExp{_op="max", _exps=[expr]}}) = "max(" ++ genConstraintPExp expr ++ ");\n" + genGoal (IEGoal _ PExp{_exp = IFunExp{_op="min", _exps=[expr]}}) = "min(" ++ genConstraintPExp expr ++ ");\n" genGoal (IEGoal _ _) = error $ "Unknown objective" genGoal _ = "" @@ -203,53 +203,53 @@ -} rewrite :: PExp -> PExp -- Rearrange right joins to left joins. - rewrite p1@PExp{iType = Just _, exp = IFunExp "." [p2, p3@PExp{exp = IFunExp "." _}]} = - p1{exp = IFunExp "." [p3{iType = iType p4, exp = IFunExp "." [p2, p4]}, p5]} + rewrite p1@PExp{_iType = Just _, _exp = IFunExp "." [p2, p3@PExp{_exp = IFunExp "." _}]} = + p1{_exp = IFunExp "." [p3{_iType = _iType p4, _exp = IFunExp "." [p2, p4]}, p5]} where - PExp{exp = IFunExp "." [p4, p5]} = rewrite p3 - rewrite p1@PExp{exp = IFunExp{op = "-", exps = [PExp{exp = IInt i}]}} = + PExp{_exp = IFunExp "." [p4, p5]} = rewrite p3 + rewrite p1@PExp{_exp = IFunExp{_op = "-", _exps = [PExp{_exp = IInt i}]}} = -- This is so that the output looks cleaner, no other purpose since the Choco optimizer -- in the backend will treat the pre-rewritten expression the same. - p1{exp = IInt (-i)} + p1{_exp = IInt (-i)} rewrite p = p genConstraintPExp :: PExp -> String - genConstraintPExp = genConstraintExp . exp . rewrite + genConstraintPExp = genConstraintExp . _exp . rewrite genConstraintExp :: IExp -> String - genConstraintExp (IDeclPExp quant [] body) = - mapQuant quant ++ "(" ++ genConstraintPExp body ++ ")" - genConstraintExp (IDeclPExp quant decls body) = - mapQuant quant ++ "([" ++ intercalate ", " (map genDecl decls) ++ "], " ++ genConstraintPExp body ++ ")" + genConstraintExp (IDeclPExp quant' [] body') = + mapQuant quant' ++ "(" ++ genConstraintPExp body' ++ ")" + genConstraintExp (IDeclPExp quant' decls' body') = + mapQuant quant' ++ "([" ++ intercalate ", " (map genDecl decls') ++ "], " ++ genConstraintPExp body' ++ ")" where - genDecl (IDecl isDisj locals body') = - (if isDisj then "disjDecl" else "decl") ++ "([" ++ intercalate ", " (map genLocal locals) ++ "], " ++ genConstraintPExp body' ++ ")" + genDecl (IDecl isDisj' locals body'') = + (if isDisj' then "disjDecl" else "decl") ++ "([" ++ intercalate ", " (map genLocal locals) ++ "], " ++ genConstraintPExp body'' ++ ")" genLocal local = local ++ " = local(\"" ++ local ++ "\")" - genConstraintExp (IFunExp "." [e1, PExp{exp = IClaferId{sident = "ref"}}]) = + genConstraintExp (IFunExp "." [e1, PExp{_exp = IClaferId{_sident = "ref"}}]) = "joinRef(" ++ genConstraintPExp e1 ++ ")" - genConstraintExp (IFunExp "." [e1, PExp{exp = IClaferId{sident = "parent"}}]) = + genConstraintExp (IFunExp "." [e1, PExp{_exp = IClaferId{_sident = "parent"}}]) = "joinParent(" ++ genConstraintPExp e1 ++ ")" - genConstraintExp (IFunExp "." [e1, PExp{exp = IClaferId{sident}}]) = - "join(" ++ genConstraintPExp e1 ++ ", " ++ sident ++ ")" + genConstraintExp (IFunExp "." [e1, PExp{_exp = IClaferId{_sident}}]) = + "join(" ++ genConstraintPExp e1 ++ ", " ++ _sident ++ ")" genConstraintExp (IFunExp "." [_, _]) = error $ "Did not rewrite all joins to left joins." genConstraintExp (IFunExp "-" [arg]) = "minus(" ++ genConstraintPExp arg ++ ")" genConstraintExp (IFunExp "-" [arg1, arg2]) = - "minus(" ++ genConstraintPExp arg1 ++ ", " ++ genConstraintPExp arg2 ++ ")" + "sub(" ++ genConstraintPExp arg1 ++ ", " ++ genConstraintPExp arg2 ++ ")" genConstraintExp (IFunExp "sum" args') - | [arg] <- args', PExp{exp = IFunExp{exps = [a, PExp{exp = IClaferId{sident = "ref"}}]}} <- rewrite arg = + | [arg] <- args', PExp{_exp = IFunExp{_exps = [a, PExp{_exp = IClaferId{_sident = "ref"}}]}} <- rewrite arg = "sum(" ++ genConstraintPExp a ++ ")" | otherwise = error "Unexpected sum argument." - genConstraintExp (IFunExp op args') = - mapFunc op ++ "(" ++ intercalate ", " (map genConstraintPExp args') ++ ")" + genConstraintExp (IFunExp op' args') = + mapFunc op' ++ "(" ++ intercalate ", " (map genConstraintPExp args') ++ ")" -- this is a keyword in Javascript so use "$this" instead - genConstraintExp IClaferId{sident = "this"} = "$this()" - genConstraintExp IClaferId{sident} - | sident `elem` claferUids = "global(" ++ sident ++ ")" - | otherwise = sident + genConstraintExp IClaferId{_sident = "this"} = "$this()" + genConstraintExp IClaferId{_sident} + | _sident `elem` claferUids = "global(" ++ _sident ++ ")" + | otherwise = _sident genConstraintExp (IInt val) = "constant(" ++ show val ++ ")" genConstraintExp e = error $ "Unknown expression: " ++ show e @@ -281,7 +281,7 @@ mapFunc "--" = "diff" mapFunc "&" = "inter" mapFunc "=>else" = "ifThenElse" - mapFunc op = error $ "Unknown op: " ++ op + mapFunc op' = error $ "Unknown op: " ++ op' {- sidentOf u = ident $ claferWithUid u scopeOf "integer" = undefined @@ -289,11 +289,11 @@ scopeOf i = fromMaybe 1 $ lookup i scopes -} bitwidth = fromMaybe 4 $ lookup "int" scopes :: Integer --- isQuant PExp{exp = IDeclPExp{}} = True +-- isQuant PExp{_exp = IDeclPExp{}} = True -- isQuant _ = False isNotAbstract :: IClafer -> Bool -isNotAbstract = not . isAbstract +isNotAbstract = not . _isAbstract iclafer :: IElement -> Maybe IClafer iclafer (IEClafer c) = Just c @@ -304,7 +304,7 @@ iconstraint _ = Nothing childClafers :: IClafer -> [(String, IClafer)] -childClafers IClafer{uid, elements} = - childClafers' uid =<< mapMaybe iclafer elements +childClafers IClafer{_uid, _elements} = + childClafers' _uid =<< mapMaybe iclafer _elements where - childClafers' parent' c@IClafer{uid, elements} = (parent', c) : (childClafers' uid =<< mapMaybe iclafer elements) + childClafers' parent' c@IClafer{_uid, _elements} = (parent', c) : (childClafers' _uid =<< mapMaybe iclafer _elements) diff --git a/src/Language/Clafer/Generator/Graph.hs b/src/Language/Clafer/Generator/Graph.hs --- a/src/Language/Clafer/Generator/Graph.hs +++ b/src/Language/Clafer/Generator/Graph.hs @@ -353,8 +353,8 @@ getDivId :: Span -> Map.Map Span [Ir] -> String getDivId s irMap = if Map.lookup s irMap == Nothing then "Uid not Found" - else let IRClafer iClafer = head $ fromJust $ Map.lookup s irMap in - uid iClafer + else let IRClafer iClaf = head $ fromJust $ Map.lookup s irMap in + _uid iClaf {-getSuperId :: Span -> Map.Map Span [Ir] -> String getSuperId s irMap = if Map.lookup s irMap == Nothing @@ -365,13 +365,13 @@ getUseId :: Span -> Map.Map Span [Ir] -> String getUseId s irMap = if Map.lookup s irMap == Nothing then "Uid not Found" - else let IRClafer iClafer = head $ fromJust $ Map.lookup s irMap in - sident $ exp $ head $ supers $ super iClafer + else let IRClafer iClaf = head $ fromJust $ Map.lookup s irMap in + _sident $ _exp $ head $ _supers $ _super iClaf getExpId :: Span -> Map.Map Span [Ir] -> String getExpId s irMap = if Map.lookup s irMap == Nothing then "Uid not Found" - else let IRPExp pexp = head $ fromJust $ Map.lookup s irMap in pid pexp + else let IRPExp pexp = head $ fromJust $ Map.lookup s irMap in _pid pexp {-while :: Bool -> [IExp] -> [IExp] while bool exp' = if bool then exp' else []-} diff --git a/src/Language/Clafer/Generator/Html.hs b/src/Language/Clafer/Generator/Html.hs --- a/src/Language/Clafer/Generator/Html.hs +++ b/src/Language/Clafer/Generator/Html.hs @@ -515,8 +515,8 @@ getDivId :: Span -> Map.Map Span [Ir] -> String getDivId s irMap = if Map.lookup s irMap == Nothing then "Uid not Found" - else let IRClafer iClafer = head $ fromJust $ Map.lookup s irMap in - uid iClafer + else let IRClafer iClaf = head $ fromJust $ Map.lookup s irMap in + _uid iClaf {-getSuperId span irMap = if Map.lookup span irMap == Nothing then "Uid not Found" @@ -526,8 +526,8 @@ getUseId :: Span -> Map.Map Span [Ir] -> (String, String) getUseId s irMap = if Map.lookup s irMap == Nothing then ("Uid not Found", "Uid not Found") - else let IRClafer iClafer = head $ fromJust $ Map.lookup s irMap in - (uid iClafer, sident $ exp $ head $ supers $ super iClafer) + else let IRClafer iClaf = head $ fromJust $ Map.lookup s irMap in + (_uid iClaf, _sident $ _exp $ head $ _supers $ _super iClaf) while :: Bool -> String -> String while bool exp' = if bool then exp' else "" diff --git a/src/Language/Clafer/Generator/Python.hs b/src/Language/Clafer/Generator/Python.hs --- a/src/Language/Clafer/Generator/Python.hs +++ b/src/Language/Clafer/Generator/Python.hs @@ -86,7 +86,7 @@ , "\tstack = []\n" , "\tmodule = Module.Module(\"\")\n" , "\tstack.append(module)\n" - , concatMap genPythonElement $ mDecls imodule + , concatMap genPythonElement $ _mDecls imodule , "\treturn module" ] diff --git a/src/Language/Clafer/Generator/Stats.hs b/src/Language/Clafer/Generator/Stats.hs --- a/src/Language/Clafer/Generator/Stats.hs +++ b/src/Language/Clafer/Generator/Stats.hs @@ -37,19 +37,19 @@ statsModule :: IModule -> Stats statsModule imodule = - execState (mapM statsElement $ mDecls imodule) $ Stats 0 0 0 0 0 (1, 1) + execState (mapM statsElement $ _mDecls imodule) $ Stats 0 0 0 0 0 (1, 1) statsClafer :: MonadState Stats m => IClafer -> m () statsClafer claf = do - if isAbstract claf + if _isAbstract claf then modify (\e -> e {naClafers = naClafers e + 1}) else - if isOverlapping $ super claf + if _isOverlapping $ _super claf then modify (\e -> e {nrClafers = nrClafers e + 1}) else modify (\e -> e {ncClafers = ncClafers e + 1}) sglCard' <- gets sglCard - modify (\e -> e {sglCard = statsCard sglCard' $ glCard claf}) - mapM_ statsElement $ elements claf + modify (\e -> e {sglCard = statsCard sglCard' $ _glCard claf}) + mapM_ statsElement $ _elements claf statsCard :: Interval -> Interval -> Interval diff --git a/src/Language/Clafer/Generator/Xml.hs b/src/Language/Clafer/Generator/Xml.hs --- a/src/Language/Clafer/Generator/Xml.hs +++ b/src/Language/Clafer/Generator/Xml.hs @@ -64,8 +64,8 @@ , " xmlns:xsi=\"http://www.w3.org/2001/XMLSchema-instance\"" , " xmlns:cl=\"http://clafer.org/ir\"" , " xsi:schemaLocation=\"http://clafer.org/ir https://github.com/gsdlab/clafer/blob/master/src/ClaferIR.xsd\">" - , tag "Name" $ mName imodule - , concatMap genXmlElement $ mDecls imodule + , tag "Name" $ _mName imodule + , concatMap genXmlElement $ _mDecls imodule , ""] diff --git a/src/Language/Clafer/Intermediate/Analysis.hs b/src/Language/Clafer/Intermediate/Analysis.hs --- a/src/Language/Clafer/Intermediate/Analysis.hs +++ b/src/Language/Clafer/Intermediate/Analysis.hs @@ -325,22 +325,22 @@ where sclafer | maybe 1 groupLow parent == 0 && maybe 1 groupHigh parent /= -1 = - SClafer (I.uid clafer) (I.uid clafer) (I.isAbstract clafer) 1 high gLow gHigh (uid <$> parent) super constraints + SClafer (I._uid clafer) (I._uid clafer) (I._isAbstract clafer) 1 high gLow gHigh (uid <$> parent) super constraints | otherwise = - SClafer (I.uid clafer) (I.uid clafer) (I.isAbstract clafer) low high gLow gHigh (uid <$> parent) super constraints - (children, constraints) = partitionEithers $ mapMaybe (convertElement' $ Just $ sclafer) (I.elements clafer) + SClafer (I._uid clafer) (I._uid clafer) (I._isAbstract clafer) low high gLow gHigh (uid <$> parent) super constraints + (children, constraints) = partitionEithers $ mapMaybe (convertElement' $ Just $ sclafer) (I._elements clafer) - Just (low, high) = I.card clafer + Just (low, high) = I._card clafer (gLow, gHigh) = - case I.gcard clafer of + case I._gcard clafer of Nothing -> (0, -1) -- TODO: Bug w/ keywords? Just (I.IGCard True _) -> (0, 1) Just (I.IGCard _ i) -> i super = - case I.super clafer of - I.ISuper True [I.PExp{I.exp = I.IClaferId{I.sident = superUid}}] -> Just $ Ref superUid - I.ISuper False [I.PExp{I.exp = I.IClaferId{I.sident = superUid}}] -> + case I._super clafer of + I.ISuper True [I.PExp{I._exp = I.IClaferId{I._sident = superUid}}] -> Just $ Ref superUid + I.ISuper False [I.PExp{I._exp = I.IClaferId{I._sident = superUid}}] -> if superUid `elem` ["string", "real", "int", "integer", "boolean"] then Just $ Ref superUid else Just $ Colon superUid @@ -357,7 +357,7 @@ sString = SClafer "string" "string" False 0 (-1) 0 (-1) Nothing Nothing [] sBoolean = SClafer "boolean" "boolean" False 0 (-1) 0 (-1) Nothing Nothing [] - root = I.IClafer noSpan False Nothing rootUid rootUid (I.ISuper False [I.PExp Nothing "" noSpan $ I.IClaferId "clafer" "clafer" True]) (Just (1, 1)) (0, 0) $ I.mDecls imodule + root = I.IClafer noSpan False Nothing rootUid rootUid (I.ISuper False [I.PExp Nothing "" noSpan $ I.IClaferId "clafer" "clafer" True]) (Just (1, 1)) (0, 0) $ I._mDecls imodule diff --git a/src/Language/Clafer/Intermediate/Desugarer.hs b/src/Language/Clafer/Intermediate/Desugarer.hs --- a/src/Language/Clafer/Intermediate/Desugarer.hs +++ b/src/Language/Clafer/Intermediate/Desugarer.hs @@ -38,7 +38,7 @@ -- [ImoduleFragment $ declarations >>= desugarEnums >>= desugarDeclaration] sugarModule :: IModule -> Module -sugarModule x = Module $ map sugarDeclaration $ mDecls x -- (fragments x >>= mDecls) +sugarModule x = Module $ map sugarDeclaration $ _mDecls x -- (fragments x >>= mDecls) -- | desugars enumeration to abstract and global singleton features desugarEnums :: Declaration -> [Declaration] @@ -203,7 +203,7 @@ (desugarClafer claf) ++ (mkArrowConstraint claf >>= desugarElement) PosClaferUse s name crd es -> desugarClafer $ PosClafer s - AbstractEmpty GCardEmpty (mkIdent $ sident $ desugarName name) + AbstractEmpty GCardEmpty (mkIdent $ _sident $ desugarName name) (SuperSome SuperColon (PosClaferId noSpan name)) crd InitEmpty es PosSubconstraint _ constraint -> [IEConstraint True $ desugarConstraint constraint] @@ -426,7 +426,7 @@ sugarExp :: PExp -> Exp -sugarExp x = sugarExp' $ Language.Clafer.Intermediate.Intclafer.exp x +sugarExp x = sugarExp' $ Language.Clafer.Intermediate.Intclafer._exp x sugarExp' :: IExp -> Exp @@ -486,7 +486,7 @@ sugarSetExp :: PExp -> SetExp -sugarSetExp x = sugarSetExp' $ Language.Clafer.Intermediate.Intclafer.exp x +sugarSetExp x = sugarSetExp' $ Language.Clafer.Intermediate.Intclafer._exp x sugarSetExp' :: IExp -> SetExp @@ -510,7 +510,7 @@ where result | isSet x = IDeclPExp ISome [] (pExpDefPid pos' x) - | isNegSome x = IDeclPExp INo [] $ bpexp $ Language.Clafer.Intermediate.Intclafer.exp $ head $ exps x + | isNegSome x = IDeclPExp INo [] $ _bpexp $ Language.Clafer.Intermediate.Intclafer._exp $ head $ _exps x | otherwise = x isNegSome (IFunExp op' [PExp _ _ _ (IDeclPExp ISome [] _)]) = op' == iNot isNegSome _ = False @@ -536,8 +536,8 @@ reduceNav :: IExp -> IExp reduceNav x@(IFunExp op' exps'@((PExp _ _ _ iexp@(IFunExp _ (pexp0:pexp:_))):pPexp:_)) = if op' == iJoin && isParent pPexp && isClaferName pexp - then reduceNav $ Language.Clafer.Intermediate.Intclafer.exp pexp0 - else x{exps = (head exps'){Language.Clafer.Intermediate.Intclafer.exp = reduceIExp iexp} : + then reduceNav $ Language.Clafer.Intermediate.Intclafer._exp pexp0 + else x{_exps = (head exps'){Language.Clafer.Intermediate.Intclafer._exp = reduceIExp iexp} : tail exps'} reduceNav x = x diff --git a/src/Language/Clafer/Intermediate/GLPKScopeAnalyzer.hs b/src/Language/Clafer/Intermediate/GLPKScopeAnalyzer.hs --- a/src/Language/Clafer/Intermediate/GLPKScopeAnalyzer.hs +++ b/src/Language/Clafer/Intermediate/GLPKScopeAnalyzer.hs @@ -106,7 +106,7 @@ constantsAnalysis = do cons <- constraintsUnder anything `select` snd - return $ mapMaybe integerConstant [I.exp sub | con <- cons, sub <- subexpressions con] + return $ mapMaybe integerConstant [I._exp sub | con <- cons, sub <- subexpressions con] where integerConstant (I.IInt i) = Just i integerConstant _ = Nothing @@ -175,9 +175,9 @@ simpleConstraintAnalysis' analysis = runListT $ do (curThis, cons) <- foreach $ constraintsUnder anything - constraintBetween curThis (I.exp cons) + constraintBetween curThis (I._exp cons) where - constraintBetween _ I.IDeclPExp {I.quant = I.ISome, I.oDecls = [], I.bpexp} = + constraintBetween _ I.IDeclPExp {I._quant = I.ISome, I._oDecls = [], I._bpexp} = do let t = map tLexeme $ fromMaybe [] $ unfoldJoins bpexp guard (not $ null t) @@ -185,8 +185,8 @@ guard ("parent" `notElem` t) guard ("ref" `notElem` t) msum $ map someStep t - constraintBetween curThis I.IFunExp{I.op = "&&", I.exps = [exp1, exp2]} = - constraintBetween curThis (I.exp exp1) `mplus` constraintBetween curThis (I.exp exp2) + constraintBetween curThis I.IFunExp{I._op = "&&", I._exps = [exp1, exp2]} = + constraintBetween curThis (I._exp exp1) `mplus` constraintBetween curThis (I._exp exp2) constraintBetween _ _ = mzero someStep step = do @@ -387,10 +387,10 @@ | inSame <- groupBy (testing' $ syntaxOf . snd) $ sortBy (comparing' snd) toOpt ] inPExp a b = I.PExp (Just I.TBoolean) "" noSpan $ I.IFunExp "in" [a, b] unionPExpAll es = foldr1 unionPExp es - unionPExp a b = I.PExp (liftM2 (+++) (I.iType a) (I.iType b)) "" noSpan $ I.IFunExp "++" [a, b] + unionPExp a b = I.PExp (liftM2 (+++) (I._iType a) (I._iType b)) "" noSpan $ I.IFunExp "++" [a, b] - partitionConstraint I.PExp{I.exp = I.IFunExp {I.op = "in", I.exps = [exp1, exp2]}} = return $ Right (exp1, exp2) - partitionConstraint I.PExp{I.exp = I.IFunExp {I.op = "&&", I.exps = [exp1, exp2]}} = partitionConstraint exp1 `mplus` partitionConstraint exp2 + partitionConstraint I.PExp{I._exp = I.IFunExp {I._op = "in", I._exps = [exp1, exp2]}} = return $ Right (exp1, exp2) + partitionConstraint I.PExp{I._exp = I.IFunExp {I._op = "&&", I._exps = [exp1, exp2]}} = partitionConstraint exp1 `mplus` partitionConstraint exp2 partitionConstraint e = return $ Left e testing' f a b = f a == f b @@ -411,16 +411,16 @@ optimizeAllConstraints curThis constraints = runListT $ partitionConstraint =<< foreachM constraints where - partitionConstraint I.PExp{I.exp = I.IDeclPExp I.IAll [I.IDecl _ [decl] I.PExp{I.exp = I.IClaferId{I.sident}}] bpexp} = + partitionConstraint I.PExp{I._exp = I.IDeclPExp I.IAll [I.IDecl _ [decl] I.PExp{I._exp = I.IClaferId{I._sident}}] bpexp} = do - under <- claferWithUid sident + under <- claferWithUid _sident return (under, rename decl bpexp) - partitionConstraint I.PExp{I.exp = I.IFunExp {I.op = "&&", I.exps = [exp1, exp2]}} = partitionConstraint exp1 `mplus` partitionConstraint exp2 + partitionConstraint I.PExp{I._exp = I.IFunExp {I._op = "&&", I._exps = [exp1, exp2]}} = partitionConstraint exp1 `mplus` partitionConstraint exp2 partitionConstraint e = return (curThis, e) rename :: String -> I.PExp -> I.PExp - rename f p@I.PExp{I.exp = exp'} = - p{I.exp = renameIExp exp'} + rename f p@I.PExp{I._exp = exp'} = + p{I._exp = renameIExp exp'} where renameIExp (I.IFunExp op exps) = I.IFunExp op $ map (rename f) exps renameIExp (I.IDeclPExp quant oDecls bpexp) = I.IDeclPExp quant (map renameDecl oDecls) $ rename f bpexp @@ -620,34 +620,34 @@ scopeConstraint :: MonadScope m => SClafer -> I.PExp -> m [(Expr, Con, Expr)] scopeConstraint curThis pexp = - runListT $ scopeConstraint' $ I.exp pexp + runListT $ scopeConstraint' $ I._exp pexp where - scopeConstraint' I.IFunExp {I.op = "&&", I.exps} = msum $ map (scopeConstraint' . I.exp) exps - scopeConstraint' I.IDeclPExp {I.quant = I.ISome, I.oDecls = [], I.bpexp} = parsePath curThis bpexp `greaterThanEqual` constant (1::Integer) - scopeConstraint' I.IDeclPExp {I.quant = I.ISome, I.oDecls} = msum $ map pathAndMultDecl oDecls + scopeConstraint' I.IFunExp {I._op = "&&", I._exps} = msum $ map (scopeConstraint' . I._exp) _exps + scopeConstraint' I.IDeclPExp {I._quant = I.ISome, I._oDecls = [], I._bpexp} = parsePath curThis _bpexp `greaterThanEqual` constant (1::Integer) + scopeConstraint' I.IDeclPExp {I._quant = I.ISome, I._oDecls} = msum $ map pathAndMultDecl _oDecls where - pathAndMultDecl I.IDecl {I.isDisj = True, I.decls, I.body} = parsePath curThis body `greaterThanEqual` constant (length decls) - pathAndMultDecl I.IDecl {I.isDisj = False, I.body} = parsePath curThis body `greaterThanEqual` constant (1::Integer) - scopeConstraint' I.IDeclPExp {I.quant = I.IOne, I.oDecls = [], I.bpexp} = parsePath curThis bpexp `eqTo` constant (1::Integer) - scopeConstraint' I.IDeclPExp {I.quant = I.IOne, I.oDecls} = + pathAndMultDecl I.IDecl {I._isDisj = True, I._decls, I._body} = parsePath curThis _body `greaterThanEqual` constant (length _decls) + pathAndMultDecl I.IDecl {I._isDisj = False, I._body} = parsePath curThis _body `greaterThanEqual` constant (1::Integer) + scopeConstraint' I.IDeclPExp {I._quant = I.IOne, I._oDecls = [], I._bpexp} = parsePath curThis _bpexp `eqTo` constant (1::Integer) + scopeConstraint' I.IDeclPExp {I._quant = I.IOne, I._oDecls} = do - oDecl <- foreachM oDecls - parsePath curThis (I.body oDecl) `eqTo` constant (1::Integer) - scopeConstraint' I.IFunExp {I.op, I.exps = [exp1, exp2]} - | op == "in" = inConstraint1 exp1 exp2 `mplus` inConstraint2 exp1 exp2 - | op == "=" = equalConstraint1 exp1 exp2 `mplus` equalConstraint2 exp1 exp2 - | op == "<" = scopeConstraintNum exp1 `lessThan` scopeConstraintNum exp2 - | op == "<=" = scopeConstraintNum exp1 `lessThanEqual` scopeConstraintNum exp2 - | op == ">" = scopeConstraintNum exp1 `greaterThan` scopeConstraintNum exp2 - | op == ">=" = scopeConstraintNum exp1 `greaterThanEqual` scopeConstraintNum exp2 - | op == "<=>" = (exp1 `implies` exp2) `mplus` (exp2 `implies` exp1) - | op == "=>" = exp1 `implies` exp2 + oDecl <- foreachM _oDecls + parsePath curThis (I._body oDecl) `eqTo` constant (1::Integer) + scopeConstraint' I.IFunExp {I._op, I._exps = [exp1, exp2]} + | _op == "in" = inConstraint1 exp1 exp2 `mplus` inConstraint2 exp1 exp2 + | _op == "=" = equalConstraint1 exp1 exp2 `mplus` equalConstraint2 exp1 exp2 + | _op == "<" = scopeConstraintNum exp1 `lessThan` scopeConstraintNum exp2 + | _op == "<=" = scopeConstraintNum exp1 `lessThanEqual` scopeConstraintNum exp2 + | _op == ">" = scopeConstraintNum exp1 `greaterThan` scopeConstraintNum exp2 + | _op == ">=" = scopeConstraintNum exp1 `greaterThanEqual` scopeConstraintNum exp2 + | _op == "<=>" = (exp1 `implies` exp2) `mplus` (exp2 `implies` exp1) + | _op == "=>" = exp1 `implies` exp2 scopeConstraint' _ = mzero implies exp1 exp2 = do - e1 <- scopeConstraint' $ I.exp exp1 - e2 <- scopeConstraint' $ I.exp exp2 + e1 <- scopeConstraint' $ I._exp exp1 + e2 <- scopeConstraint' $ I._exp exp2 case (e1, e2) of ((This thisPath t1, GEQ, Const 1), (Global globalPath t0, comp, Positive allPaths c t2)) -> @@ -687,7 +687,7 @@ _ -> mzero inConstraint2 exp1 exp2 = scopeConstraintNum exp1 `lessThanEqual` scopeConstraintNum exp2 - scopeConstraintSet I.PExp {I.exp = I.IFunExp {I.op = "++", I.exps = [e1, e2]}} = + scopeConstraintSet I.PExp {I._exp = I.IFunExp {I._op = "++", I._exps = [e1, e2]}} = do l1' <- scopeConstraintSet e1 l2' <- scopeConstraintSet e2 @@ -709,8 +709,8 @@ flattenConcat (Concat es _) = es >>= flattenConcat flattenConcat e = [e] - scopeConstraintNum I.PExp {I.exp = I.IInt const'} = constant const' - scopeConstraintNum I.PExp {I.exp = I.IFunExp {I.op = "#", I.exps = [path]}} = parsePath curThis path + scopeConstraintNum I.PExp {I._exp = I.IInt const'} = constant const' + scopeConstraintNum I.PExp {I._exp = I.IFunExp {I._op = "#", I._exps = [path]}} = parsePath curThis path scopeConstraintNum _ = mzero constant :: (Monad m, Integral i) => i -> m Expr @@ -844,10 +844,10 @@ unfoldJoins pexp = unfoldJoins' pexp where - unfoldJoins' I.PExp{I.exp = (I.IFunExp "." args)} = + unfoldJoins' I.PExp{I._exp = (I.IFunExp "." args)} = return $ args >>= (fromMaybe [] . unfoldJoins) - unfoldJoins' I.PExp{I.inPos, I.exp = I.IClaferId{I.sident}} = - return $ [Token (spanToSourcePos inPos) sident] + unfoldJoins' I.PExp{I._inPos, I._exp = I.IClaferId{I._sident}} = + return $ [Token (spanToSourcePos _inPos) _sident] unfoldJoins' _ = fail "not a join" @@ -1016,12 +1016,12 @@ -} subexpressions :: I.PExp -> [I.PExp] -subexpressions p@I.PExp{I.exp = exp'} = +subexpressions p@I.PExp{I._exp = exp'} = p : subexpressions' exp' where - subexpressions' I.IDeclPExp{I.oDecls, I.bpexp} = - concatMap (subexpressions . I.body) oDecls ++ subexpressions bpexp - subexpressions' I.IFunExp{I.exps} = concatMap subexpressions exps + subexpressions' I.IDeclPExp{I._oDecls, I._bpexp} = + concatMap (subexpressions . I._body) _oDecls ++ subexpressions _bpexp + subexpressions' I.IFunExp{I._exps} = concatMap subexpressions _exps subexpressions' _ = [] instance MonadSupply s m => MonadSupply s (ListT m) where diff --git a/src/Language/Clafer/Intermediate/Intclafer.hs b/src/Language/Clafer/Intermediate/Intclafer.hs --- a/src/Language/Clafer/Intermediate/Intclafer.hs +++ b/src/Language/Clafer/Intermediate/Intclafer.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TemplateHaskell, DeriveDataTypeable #-} {- Copyright (C) 2012-2014 Kacper Bak, Jimmy Liang, Luke Michael Brown @@ -23,6 +24,8 @@ module Language.Clafer.Intermediate.Intclafer where import Language.Clafer.Front.Absclafer +import Control.Lens +import Data.Data import Data.Monoid import Data.Foldable (foldMap) @@ -50,57 +53,62 @@ | TInteger | TReal | TClafer [String] - deriving (Eq,Ord,Show) + deriving (Eq,Ord,Show,Data,Typeable) -- | each file contains exactly one mode. A module is a list of declarations data IModule = IModule { -- | always empty for now because we don't have syntax for declaring modules - mName :: String, + _mName :: String, -- | List of top-level elements - mDecls :: [IElement] + _mDecls :: [IElement] } - deriving (Eq,Ord,Show) + deriving (Eq,Ord,Show,Data,Typeable) -- | Clafer has a list of fields that specify its properties. Some fields, marked as (o) are for generating optimized code data IClafer = IClafer { -- | the position of the syntax in source code - cinPos :: Span, + _cinPos :: Span, -- | whether abstract or not (i.e., concrete) - isAbstract :: Bool, + _isAbstract :: Bool, -- | group cardinality - gcard :: Maybe IGCard, + _gcard :: Maybe IGCard, -- | name declared in the model - ident :: CName, + _ident :: CName, -- | a unique identifier - uid :: UID, + _uid :: UID, -- | superclafers - super:: ISuper, + _super:: ISuper, -- | clafer cardinality - card :: Maybe Interval, + _card :: Maybe Interval, -- | (o) global cardinality - glCard :: Interval, + _glCard :: Interval, -- | nested elements - elements :: [IElement] + _elements :: [IElement] } - deriving (Eq,Ord,Show) + deriving (Eq,Ord,Show,Data,Typeable) -- | Clafer's subelement is either a clafer, a constraint, or a goal (objective) -- This is a wrapper type needed to have polymorphic lists of elements data IElement = - IEClafer IClafer + IEClafer { + -- | the actual clafer + _iClafer :: IClafer + } | IEConstraint { -- | whether hard or not (soft) - isHard :: Bool, + _isHard :: Bool, -- | the container of the actual expression - cpexp :: PExp + _cpexp :: PExp } -- | Goal (optimization objective) | IEGoal { - isMaximize :: Bool, -- whether maximize or minimize - cpexp :: PExp -- the expression + -- | whether maximize or minimize + _isMaximize :: Bool, + -- | the expression + _cpexp :: PExp } - deriving (Eq,Ord,Show) + deriving (Eq,Ord,Show,Data,Typeable) -- | A list of superclafers. -- -> overlaping unique (set) @@ -108,20 +116,20 @@ -- : non overlapping (disjoint) data ISuper = ISuper { - isOverlapping :: Bool, -- whether overlapping or disjoint with other clafers extending given list of superclafers - supers :: [PExp] + _isOverlapping :: Bool, -- whether overlapping or disjoint with other clafers extending given list of superclafers + _supers :: [PExp] } - deriving (Eq,Ord,Show) + deriving (Eq,Ord,Show,Data,Typeable) -- | Group cardinality is specified as an interval. It may also be given by a keyword. -- xor 1..1 isKeyword = True -- 1..1 1..1 isKeyword = False data IGCard = IGCard { - isKeyword :: Bool, -- whether given by keyword: or, xor, mux - interval :: Interval + _isKeyword :: Bool, -- whether given by keyword: or, xor, mux + _interval :: Interval } - deriving (Eq,Ord,Show) + deriving (Eq,Ord,Show,Data,Typeable) -- | (Min, Max) integer interval. -1 denotes * type Interval = (Integer, Integer) @@ -130,26 +138,32 @@ -- It has meta information about an actual expression 'exp' data PExp = PExp { -- | the inferred type - iType :: Maybe IType, + _iType :: Maybe IType, -- | non-empty unique id for expressions with span, \"\" for noSpan - pid :: String, + _pid :: String, -- | position in the input Clafer file - inPos :: Span, + _inPos :: Span, -- | the actual expression - exp :: IExp + _exp :: IExp } - deriving (Eq,Ord,Show) - + deriving (Eq,Ord,Show,Data,Typeable) data IExp = -- | quantified expression with declarations -- e.g., [ all x1; x2 : X | x1.ref != x2.ref ] - IDeclPExp {quant :: IQuant, oDecls :: [IDecl], bpexp :: PExp} + IDeclPExp { + _quant :: IQuant, + _oDecls :: [IDecl], + _bpexp :: PExp + } -- | expression with a -- unary function, e.g., -1 -- binary function, e.g., 2 + 3 -- ternary function, e.g., if x then 4 else 5 - | IFunExp {op :: String, exps :: [PExp]} + | IFunExp { + _op :: String, + _exps :: [PExp] + } -- | integer number | IInt Integer -- | real number @@ -159,13 +173,13 @@ -- | a reference to a clafer name | IClaferId { -- | module name - currently not used and empty since we have no module system - modName :: String, + _modName :: String, -- | name of the clafer being referred to - sident :: CName, + _sident :: CName, -- | identifier refers to a top-level definition - isTop :: Bool + _isTop :: Bool } - deriving (Eq,Ord,Show) + deriving (Eq,Ord,Show,Data,Typeable) {- | For IFunExp standard set of operators includes: @@ -209,13 +223,13 @@ data IDecl = IDecl { -- | is disjunct - isDisj :: Bool, + _isDisj :: Bool, -- | a list of local names - decls :: [CName], + _decls :: [CName], -- | set to which local names refer to - body :: PExp + _body :: PExp } - deriving (Eq,Ord,Show) + deriving (Eq,Ord,Show,Data,Typeable) -- | quantifier data IQuant = @@ -229,7 +243,7 @@ | ISome -- | for all | IAll - deriving (Eq,Ord,Show) + deriving (Eq,Ord,Show,Data,Typeable) type LineNo = Integer type ColNo = Integer @@ -341,4 +355,25 @@ unWrapIDecl x = error $ "Can't call unWarpIDecl on " ++ show x unWrapIGCard :: Ir -> IGCard unWrapIGCard (IRIGCard x) = x -unWrapIGCard x = error $ "Can't call unWarpIGcard on " ++ show x +unWrapIGCard x = error $ "Can't call unWarpIGcard on " ++ show x + + +instance Plated IClafer +instance Plated PExp +instance Plated IExp + +makeLenses ''IModule + +makeLenses ''IClafer + +makeLenses ''IElement + +makeLenses ''ISuper + +makeLenses ''IGCard + +makeLenses ''PExp + +makeLenses ''IExp + +makeLenses ''IDecl diff --git a/src/Language/Clafer/Intermediate/Resolver.hs b/src/Language/Clafer/Intermediate/Resolver.hs --- a/src/Language/Clafer/Intermediate/Resolver.hs +++ b/src/Language/Clafer/Intermediate/Resolver.hs @@ -46,9 +46,9 @@ -- | Name resolver nameModule :: Bool -> IModule -> (IModule, GEnv) -nameModule skipResolver imodule = (imodule{mDecls = decls'}, genv') +nameModule skipResolver imodule = (imodule{_mDecls = decls'}, genv') where - (decls', genv') = runState (mapM (nameElement skipResolver) $ mDecls imodule) $ GEnv Map.empty 0 Map.empty [] + (decls', genv') = runState (mapM (nameElement skipResolver) $ _mDecls imodule) $ GEnv Map.empty 0 Map.empty [] nameElement :: MonadState GEnv m => Bool -> IElement -> m IElement nameElement skipResolver x = case x of @@ -59,9 +59,9 @@ nameClafer :: MonadState GEnv m => Bool -> IClafer -> m IClafer nameClafer skipResolver claf = do - claf' <- if skipResolver then return claf{uid = ident claf} else (renameClafer (not skipResolver)) claf - elements' <- mapM (nameElement skipResolver) $ elements claf - return $ claf' {elements = elements'} + claf' <- if skipResolver then return claf{_uid = _ident claf} else (renameClafer (not skipResolver)) claf + elements' <- mapM (nameElement skipResolver) $ _elements claf + return $ claf' {_elements = elements'} namePExp :: MonadState GEnv m => PExp -> m PExp @@ -69,7 +69,7 @@ n <- gets expCount modify (\e -> e {expCount = 1 + n}) exp'' <- nameIExp exp' - return $ pexp {pid = concat [ "e", show n, "_"], Language.Clafer.Intermediate.Intclafer.exp = exp''} + return $ pexp {_pid = concat [ "e", show n, "_"], Language.Clafer.Intermediate.Intclafer._exp = exp''} nameIExp :: MonadState GEnv m => IExp -> m IExp nameIExp x = case x of diff --git a/src/Language/Clafer/Intermediate/ResolverInheritance.hs b/src/Language/Clafer/Intermediate/ResolverInheritance.hs --- a/src/Language/Clafer/Intermediate/ResolverInheritance.hs +++ b/src/Language/Clafer/Intermediate/ResolverInheritance.hs @@ -43,19 +43,19 @@ resolveNModule :: (IModule, GEnv) -> Resolve (IModule, GEnv) resolveNModule (imodule, genv') = do - let decls' = mDecls imodule + let decls' = _mDecls imodule decls'' <- mapM (resolveNElement decls') decls' - return (imodule{mDecls = decls''}, genv' {sClafers = bfs toNodeShallow $ toClafers decls''}) + return (imodule{_mDecls = decls''}, genv' {sClafers = bfs toNodeShallow $ toClafers decls''}) resolveNClafer :: [IElement] -> IClafer -> Resolve IClafer resolveNClafer declarations clafer = do - super' <- resolveNSuper declarations $ super clafer - elements' <- mapM (resolveNElement declarations) $ elements clafer - return $ clafer {super = super', - elements = elements'} + super' <- resolveNSuper declarations $ _super clafer + elements' <- mapM (resolveNElement declarations) $ _elements clafer + return $ clafer {_super = super', + _elements = elements'} resolveNSuper :: [IElement] -> ISuper -> Resolve ISuper @@ -80,24 +80,24 @@ resolveN :: Span -> [IElement] -> String -> Resolve (Maybe (String, [IClafer])) resolveN pos' declarations id' = - findUnique pos' id' $ map (\x -> (x, [x])) $ filter isAbstract $ bfsClafers $ + findUnique pos' id' $ map (\x -> (x, [x])) $ filter _isAbstract $ bfsClafers $ toClafers declarations -- | Resolve overlapping inheritance resolveOModule :: (IModule, GEnv) -> Resolve (IModule, GEnv) resolveOModule (imodule, genv') = do - let decls' = mDecls imodule + let decls' = _mDecls imodule decls'' <- mapM (resolveOElement (defSEnv genv' decls')) decls' - return (imodule {mDecls = decls''}, genv' {sClafers = bfs toNodeShallow $ toClafers decls''}) + return (imodule {_mDecls = decls''}, genv' {sClafers = bfs toNodeShallow $ toClafers decls''}) resolveOClafer :: SEnv -> IClafer -> Resolve IClafer resolveOClafer env clafer = do - super' <- resolveOSuper env {context = Just clafer} $ super clafer - elements' <- mapM (resolveOElement env {context = Just clafer}) $ elements clafer - return $ clafer {super = super', elements = elements'} + super' <- resolveOSuper env {context = Just clafer} $ _super clafer + elements' <- mapM (resolveOElement env {context = Just clafer}) $ _elements clafer + return $ clafer {_super = super', _elements = elements'} resolveOSuper :: SEnv -> ISuper -> Resolve ISuper @@ -119,18 +119,18 @@ -- | Resolve inherited and default cardinalities analyzeModule :: (IModule, GEnv) -> IModule analyzeModule (imodule, genv') = - imodule{mDecls = map (analyzeElement (defSEnv genv' decls')) decls'} + imodule{_mDecls = map (analyzeElement (defSEnv genv' decls')) decls'} where - decls' = mDecls imodule + decls' = _mDecls imodule analyzeClafer :: SEnv -> IClafer -> IClafer analyzeClafer env clafer = - clafer' {elements = map (analyzeElement env {context = Just clafer'}) $ - elements clafer'} + clafer' {_elements = map (analyzeElement env {context = Just clafer'}) $ + _elements clafer'} where - clafer' = clafer {gcard = analyzeGCard env clafer, - card = analyzeCard env clafer} + clafer' = clafer {_gcard = analyzeGCard env clafer, + _card = analyzeCard env clafer} -- only for non-overlapping @@ -138,20 +138,20 @@ analyzeGCard env clafer = gcard' `mplus` (Just $ IGCard False (0, -1)) where gcard' - | isOverlapping $ super clafer = gcard clafer - | otherwise = listToMaybe $ mapMaybe gcard $ + | _isOverlapping $ _super clafer = _gcard clafer + | otherwise = listToMaybe $ mapMaybe _gcard $ findHierarchy getSuper (clafers env) clafer analyzeCard :: SEnv -> IClafer -> Maybe Interval -analyzeCard env clafer = card clafer `mplus` Just card' +analyzeCard env clafer = _card clafer `mplus` Just card' where card' - | isAbstract clafer = (0, -1) + | _isAbstract clafer = (0, -1) | (isJust $ context env) && pGcard == (0, -1) - || (isTopLevel $ cinPos clafer) = (1, 1) + || (isTopLevel $ _cinPos clafer) = (1, 1) | otherwise = (0, 1) - pGcard = interval $ fromJust $ gcard $ fromJust $ context env + pGcard = _interval $ fromJust $ _gcard $ fromJust $ context env isTopLevel (Span (Pos _ c) _) = c==1 isTopLevel (Span (PosPos _ _ c) _) = c==1 isTopLevel (PosSpan _ (Pos _ c) _) = c==1 @@ -165,9 +165,9 @@ -- | Expand inheritance resolveEModule :: (IModule, GEnv) -> (IModule, GEnv) -resolveEModule (imodule, genv') = (imodule{mDecls = decls''}, genv'') +resolveEModule (imodule, genv') = (imodule{_mDecls = decls''}, genv'') where - decls' = mDecls imodule + decls' = _mDecls imodule (decls'', genv'') = runState (mapM (resolveEElement [] (unrollableModule imodule) False decls') decls') genv' @@ -175,23 +175,23 @@ -- ----------------------------------------------------------------------------- unrollableModule :: IModule -> [String] unrollableModule imodule = getDirUnrollables $ - mapMaybe unrollabeDeclaration $ mDecls imodule + mapMaybe unrollabeDeclaration $ _mDecls imodule unrollabeDeclaration :: IElement -> Maybe (String, [String]) unrollabeDeclaration x = case x of - IEClafer clafer -> if isAbstract clafer - then Just (uid clafer, unrollableClafer clafer) + IEClafer clafer -> if _isAbstract clafer + then Just (_uid clafer, unrollableClafer clafer) else Nothing IEConstraint _ _ -> Nothing IEGoal _ _ -> Nothing unrollableClafer :: IClafer -> [String] unrollableClafer clafer - | isOverlapping $ super clafer = [] + | _isOverlapping $ _super clafer = [] | getSuper clafer == "clafer" = deps | otherwise = getSuper clafer : deps where - deps = (toClafers $ elements clafer) >>= unrollableClafer + deps = (toClafers $ _elements clafer) >>= unrollableClafer getDirUnrollables :: [(String, [String])] -> [String] @@ -207,18 +207,18 @@ resolveEClafer predecessors unrollables absAncestor declarations clafer = do sClafers' <- gets sClafers clafer' <- renameClafer absAncestor clafer - let predecessors' = uid clafer' : predecessors + let predecessors' = _uid clafer' : predecessors (sElements, super', superList) <- resolveEInheritance predecessors' unrollables absAncestor declarations (findHierarchy getSuper sClafers' clafer) - let sClafer = Map.fromList $ zip (map uid superList) $ repeat [predecessors'] + let sClafer = Map.fromList $ zip (map _uid superList) $ repeat [predecessors'] modify (\e -> e {stable = Map.delete "clafer" $ Map.unionWith ((nub.).(++)) sClafer $ stable e}) elements' <- mapM (resolveEElement predecessors' unrollables absAncestor declarations) - $ elements clafer - return $ clafer' {super = super', elements = elements' ++ sElements} + $ _elements clafer + return $ clafer' {_super = super', _elements = elements' ++ sElements} renameClafer :: MonadState GEnv m => Bool -> IClafer -> m IClafer renameClafer False clafer = return clafer @@ -226,26 +226,26 @@ renameClafer' :: MonadState GEnv m => IClafer -> m IClafer renameClafer' clafer = do - let claferIdent = ident clafer + let claferIdent = _ident clafer identCountMap' <- gets identCountMap let count = Map.findWithDefault 0 claferIdent identCountMap' modify (\e -> e { identCountMap = Map.alter (\_ -> Just (count+1)) claferIdent identCountMap' } ) - return $ clafer { uid = genId claferIdent count } + return $ clafer { _uid = genId claferIdent count } genId :: String -> Int -> String genId id' count = concat ["c", show count, "_", id'] resolveEInheritance :: MonadState GEnv m => [String] -> [String] -> Bool -> [IElement] -> [IClafer] -> m ([IElement], ISuper, [IClafer]) resolveEInheritance predecessors unrollables absAncestor declarations allSuper - | isOverlapping $ super clafer = return ([], super clafer, [clafer]) + | _isOverlapping $ _super clafer = return ([], _super clafer, [clafer]) | otherwise = do let superList = (if absAncestor then id else tail) allSuper - let unrollSuper = filter (\s -> uid s `notElem` unrollables) $ tail allSuper + let unrollSuper = filter (\s -> _uid s `notElem` unrollables) $ tail allSuper elements' <- mapM (resolveEElement predecessors unrollables True declarations) $ - unrollSuper >>= elements + unrollSuper >>= _elements let super' = if (getSuper clafer `elem` unrollables) - then super clafer + then _super clafer else ISuper False [idToPExp "" noSpan "" "clafer" False] return (elements', super', superList) where @@ -253,7 +253,7 @@ resolveEElement :: MonadState GEnv m => [String] -> [String] -> Bool -> [IElement] -> IElement -> m IElement resolveEElement predecessors unrollables absAncestor declarations x = case x of - IEClafer clafer -> if isAbstract clafer then return x else IEClafer `liftM` + IEClafer clafer -> if _isAbstract clafer then return x else IEClafer `liftM` resolveEClafer predecessors unrollables absAncestor declarations clafer IEConstraint _ _ -> return x IEGoal _ _ -> return x diff --git a/src/Language/Clafer/Intermediate/ResolverName.hs b/src/Language/Clafer/Intermediate/ResolverName.hs --- a/src/Language/Clafer/Intermediate/ResolverName.hs +++ b/src/Language/Clafer/Intermediate/ResolverName.hs @@ -79,19 +79,19 @@ where env = SEnv (toClafers declarations) Nothing [] [] [] [] genv' [] [] rCl cs = bfs toNodeDeep $ map (\c -> env{context = Just c, resPath = [c]}) cs - (aClafers', cClafers') = partition isAbstract $ clafers env + (aClafers', cClafers') = partition _isAbstract $ clafers env checkDuplicateSiblings :: IModule -> Resolve [IElement] -checkDuplicateSiblings tree = let duplicate = checkDuplicateSiblings' $ mDecls tree +checkDuplicateSiblings tree = let duplicate = checkDuplicateSiblings' $ _mDecls tree in if (isJust duplicate) then let Just(name,pos') = duplicate in throwError $ SemanticErr pos' $ ("Duplicate name: " ++ name) --error - else return $ mDecls tree + else return $ _mDecls tree checkDuplicateSiblings' :: [IElement] -> Maybe (String,Span) checkDuplicateSiblings' tree =if (isJust check) then check else checkForJust $ map checkDuplicateSiblings' elementsList where - check = checkListDuplicates $ map (\c -> (ident c, cinPos c)) $ map (\(IEClafer eclafer) -> eclafer) $ filter isIEClafer tree - elementsList = map (\c -> elements c) $ map (\(IEClafer eclafer) -> eclafer) $ filter isIEClafer tree + check = checkListDuplicates $ map (\c -> (_ident c, _cinPos c)) $ map (\(IEClafer eclafer) -> eclafer) $ filter isIEClafer tree + elementsList = map (\c -> _elements c) $ map (\(IEClafer eclafer) -> eclafer) $ filter isIEClafer tree checkForJust :: [Maybe (String,Span)] -> Maybe (String,Span) @@ -121,15 +121,15 @@ do decls' <- checkDuplicateSiblings imodule mDecls' <- mapM (resolveElement (defSEnv genv' decls')) decls' - return $ imodule{mDecls = mDecls'} + return $ imodule{_mDecls = mDecls'} resolveClafer :: SEnv -> IClafer -> Resolve IClafer resolveClafer env clafer = do elements' <- mapM (resolveElement env'{subClafers = subClafers', ancClafers = ancClafers'}) $ - elements clafer - return $ clafer {elements = elements'} + _elements clafer + return $ clafer {_elements = elements'} where env' = env {context = Just clafer, resPath = clafer : resPath env} subClafers' = tail $ bfs toNodeDeep [env'{resPath = [clafer]}] @@ -149,8 +149,8 @@ resolvePExp :: SEnv -> PExp -> Resolve PExp resolvePExp env pexp = do - exp' <- resolveIExp (inPos pexp) env $ Language.Clafer.Intermediate.Intclafer.exp pexp - return $ pexp {Language.Clafer.Intermediate.Intclafer.exp = exp'} + exp' <- resolveIExp (_inPos pexp) env $ Language.Clafer.Intermediate.Intclafer._exp pexp + return $ pexp {Language.Clafer.Intermediate.Intclafer._exp = exp'} resolveIExp :: Span -> SEnv -> IExp -> Resolve IExp resolveIExp pos' env x = case x of @@ -173,17 +173,17 @@ processDecl :: MonadState SEnv m => IDecl -> m (Resolve IDecl) processDecl decl = runErrorT $ do env <- lift $ get - (body', path) <- liftError $ resolveNav (inPos $ body decl) env (Language.Clafer.Intermediate.Intclafer.exp $ body decl) True - lift $ modify (\e -> e { bindings = (decls decl, path) : bindings e }) - return $ decl {body = pExpDefPidPos body'} + (body', path) <- liftError $ resolveNav (_inPos $ _body decl) env (I._exp $ _body decl) True + lift $ modify (\e -> e { bindings = (_decls decl, path) : bindings e }) + return $ decl {_body = pExpDefPidPos body'} resolveNav :: Span -> SEnv -> IExp -> Bool -> Resolve (IExp, [IClafer]) resolveNav pos' env x isFirst = case x of IFunExp _ (pexp0:pexp:_) -> do - (exp0', path) <- resolveNav (inPos pexp0) env (Language.Clafer.Intermediate.Intclafer.exp pexp0) True - (exp', path') <- resolveNav (inPos pexp) env {context = listToMaybe path, resPath = path} - (Language.Clafer.Intermediate.Intclafer.exp pexp) False - return (IFunExp iJoin [pexp0{I.exp=exp0'}, pexp{I.exp=exp'}], path') + (exp0', path) <- resolveNav (_inPos pexp0) env (I._exp pexp0) True + (exp', path') <- resolveNav (_inPos pexp) env {context = listToMaybe path, resPath = path} + (I._exp pexp) False + return (IFunExp iJoin [pexp0{I._exp=exp0'}, pexp{I._exp=exp'}], path') IClaferId modName' id' _ -> out where out @@ -197,10 +197,10 @@ Binding -> (mkLClaferId id' True, path) Special -> (specIExp, path) TypeSpecial -> (mkLClaferId id' True, path) - Subclafers -> (toNav $ tail $ reverse $ map uid path, path) - Ancestor -> (toNav' $ adjustAncestor (reverse $ map uid $ resPath env) - (reverse $ map uid path), path) - _ -> (toNav' $ reverse $ map uid path, path) + Subclafers -> (toNav $ tail $ reverse $ map _uid path, path) + Ancestor -> (toNav' $ adjustAncestor (reverse $ map _uid $ resPath env) + (reverse $ map _uid path), path) + _ -> (toNav' $ reverse $ map _uid path, path) where toNav = foldl (\exp' id'' -> IFunExp iJoin [pExpDefPidPos exp', mkPLClaferId id'' False]) @@ -244,7 +244,7 @@ resolveNone :: Span -> SEnv -> String -> Resolve t resolveNone pos' env id' = throwError $ SemanticErr pos' $ "resolver: " ++ id' ++ " not found" ++ - " within " ++ (showPath $ map uid $ resPath env) + " within " ++ (showPath $ map _uid $ resPath env) -- checks if ident is one of special identifiers @@ -324,17 +324,17 @@ selectChildren :: (IClafer -> String) -> SEnv -> [IClafer] selectChildren f env = getSubclafers $ concat $ - mapHierarchy elements f (sClafers $ genv env) + mapHierarchy _elements f (sClafers $ genv env) (fromJust $ context env) findUnique :: Span -> String -> [(IClafer, [IClafer])] -> Resolve (Maybe (String, [IClafer])) findUnique pos' x xs = case filterPaths x $ nub xs of [] -> return $ Nothing - [elem'] -> return $ Just $ (uid $ fst elem', snd elem') + [elem'] -> return $ Just $ (_uid $ fst elem', snd elem') xs' -> throwError $ SemanticErr pos' $ "clafer " ++ show x ++ " " ++ errMsg where - xs'' = map ((map uid).snd) xs' + xs'' = map ((map _uid).snd) xs' errMsg = (if isNamespaceConflict xs'' then "cannot be defined because the name should be unique in the same namespace.\n" else "is not unique. ") ++ @@ -344,7 +344,7 @@ findFirst x xs = case filterPaths x $ nub xs of [] -> Nothing - (ele:_) -> Just $ (uid $ fst ele, snd ele) + (ele:_) -> Just $ (_uid $ fst ele, snd ele) showPath :: [String] -> String showPath xs = (intercalate "." $ reverse xs) ++ "\n" @@ -355,4 +355,4 @@ ++ " of at least two elements, but was given " ++ show x filterPaths :: String -> [(IClafer, [IClafer])] -> [(IClafer, [IClafer])] -filterPaths x xs = filter (((==) x).ident.fst) xs +filterPaths x xs = filter (((==) x)._ident.fst) xs diff --git a/src/Language/Clafer/Intermediate/ResolverType.hs b/src/Language/Clafer/Intermediate/ResolverType.hs --- a/src/Language/Clafer/Intermediate/ResolverType.hs +++ b/src/Language/Clafer/Intermediate/ResolverType.hs @@ -193,27 +193,27 @@ resolveTModule :: (IModule, GEnv) -> Either ClaferSErr IModule resolveTModule (imodule, _) = - case runTypeAnalysis (analysis $ mDecls imodule) imodule of - Right mDecls' -> return imodule{mDecls = mDecls'} + case runTypeAnalysis (analysis $ _mDecls imodule) imodule of + Right mDecls' -> return imodule{_mDecls = mDecls'} Left err -> throwError err where - analysis decls = mapM (resolveTElement $ rootUid) decls + analysis decls1 = mapM (resolveTElement $ rootUid) decls1 resolveTElement :: String -> IElement -> TypeAnalysis IElement resolveTElement _ (IEClafer iclafer) = do - elements' <- mapM (resolveTElement $ I.uid iclafer) (elements iclafer) - return $ IEClafer $ iclafer{elements = elements'} -resolveTElement parent' (IEConstraint isHard pexp) = - IEConstraint isHard <$> (testBoolean =<< resolveTConstraint parent' pexp) + elements' <- mapM (resolveTElement $ I._uid iclafer) (_elements iclafer) + return $ IEClafer $ iclafer{_elements = elements'} +resolveTElement parent' (IEConstraint _isHard _pexp) = + IEConstraint _isHard <$> (testBoolean =<< resolveTConstraint parent' _pexp) where testBoolean pexp' = do unless (typeOf pexp' == TBoolean) $ - throwError $ SemanticErr (inPos pexp') ("Cannot construct constraint on type '" ++ str (typeOf pexp') ++ "'") + throwError $ SemanticErr (_inPos pexp') ("Cannot construct constraint on type '" ++ str (typeOf pexp') ++ "'") return pexp' -resolveTElement parent' (IEGoal isMaximize pexp) = - IEGoal isMaximize <$> resolveTConstraint parent' pexp +resolveTElement parent' (IEGoal isMaximize' pexp') = + IEGoal isMaximize' <$> resolveTConstraint parent' pexp' resolveTConstraint :: String -> PExp -> TypeAnalysis PExp resolveTConstraint curThis' constraint = @@ -232,7 +232,7 @@ (_, xs) -> return xs -- Case 3: At least one success. resolveTPExp' :: PExp -> TypeAnalysis [Either ClaferSErr PExp] -resolveTPExp' p@PExp{inPos, exp = IClaferId{sident = "ref"}} = +resolveTPExp' p@PExp{_inPos, _exp = IClaferId{_sident = "ref"}} = runListT $ runErrorT $ do curPath' <- curPath case curPath' of @@ -241,76 +241,76 @@ t <- runListT $ refOf =<< foreachM ut case fromUnionType t of Just t' -> return $ p `withType` t' - Nothing -> throwError $ SemanticErr inPos ("Cannot ref from type '" ++ str curPath'' ++ "'") - Nothing -> throwError $ SemanticErr inPos ("Cannot ref at the start of a path") -resolveTPExp' p@PExp{inPos, exp = IClaferId{sident = "parent"}} = + Nothing -> throwError $ SemanticErr _inPos ("Cannot ref from type '" ++ str curPath'' ++ "'") + Nothing -> throwError $ SemanticErr _inPos ("Cannot ref at the start of a path") +resolveTPExp' p@PExp{_inPos, _exp = IClaferId{_sident = "parent"}} = runListT $ runErrorT $ do curPath' <- curPath case curPath' of Just curPath'' -> do parent' <- fromUnionType <$> runListT (parentOf =<< liftList (unionType curPath'')) when (isNothing parent') $ - throwError $ SemanticErr inPos "Cannot parent from root" + throwError $ SemanticErr _inPos "Cannot parent from root" let result = p `withType` fromJust parent' return result -- Case 1: Use the sident <++> addRef result -- Case 2: Dereference the sident 1..* times - Nothing -> throwError $ SemanticErr inPos "Cannot parent at the start of a path" -resolveTPExp' p@PExp{exp = IClaferId{sident = "integer"}} = runListT $ runErrorT $ return $ p `withType` TInteger -resolveTPExp' p@PExp{inPos, exp = IClaferId{sident}} = + Nothing -> throwError $ SemanticErr _inPos "Cannot parent at the start of a path" +resolveTPExp' p@PExp{_exp = IClaferId{_sident = "integer"}} = runListT $ runErrorT $ return $ p `withType` TInteger +resolveTPExp' p@PExp{_inPos, _exp = IClaferId{_sident}} = runListT $ runErrorT $ do curPath' <- curPath - sident' <- if sident == "this" then uid <$> curThis else return sident + sident' <- if _sident == "this" then uid <$> curThis else return _sident when (isJust curPath') $ do c <- mapM (isChild sident') $ unionType $ fromJust curPath' - unless (or c) $ throwError $ SemanticErr inPos ("'" ++ sident' ++ "' is not a child of type '" ++ str (fromJust curPath') ++ "'") + unless (or c) $ throwError $ SemanticErr _inPos ("'" ++ sident' ++ "' is not a child of type '" ++ str (fromJust curPath') ++ "'") result <- (p `withType`) <$> typeOfUid sident' return result -- Case 1: Use the sident <++> addRef result -- Case 2: Dereference the sident 1..* times -resolveTPExp' p@PExp{inPos, exp} = +resolveTPExp' p@PExp{_inPos, _exp} = runListT $ runErrorT $ do - (iType', exp') <- ErrorT $ ListT $ resolveTExp exp - return p{iType = Just iType', exp = exp'} + (iType', exp') <- ErrorT $ ListT $ resolveTExp _exp + return p{_iType = Just iType', _exp = exp'} where resolveTExp :: IExp -> TypeAnalysis [Either ClaferSErr (IType, IExp)] resolveTExp e@(IInt _) = runListT $ runErrorT $ return (TInteger, e) resolveTExp e@(IDouble _) = runListT $ runErrorT $ return (TReal, e) resolveTExp e@(IStr _) = runListT $ runErrorT $ return (TString, e) - resolveTExp e@IFunExp {op, exps = [arg]} = + resolveTExp e@IFunExp {_op, _exps = [arg]} = runListT $ runErrorT $ do arg' <- lift $ ListT $ resolveTPExp arg let t = typeOf arg' let test c = unless c $ - throwError $ SemanticErr inPos ("Function '" ++ op ++ "' cannot be performed on " ++ op ++ " '" ++ str t ++ "'") + throwError $ SemanticErr _inPos ("Function '" ++ _op ++ "' cannot be performed on " ++ _op ++ " '" ++ str t ++ "'") let result - | op == iNot = test (t == TBoolean) >> return TBoolean - | op == iCSet = return TInteger - | op == iSumSet = test (t == TInteger) >> return TInteger - | op `elem` [iMin, iGMin, iGMax] = test (numeric t) >> return t - | otherwise = error $ "Unknown op '" ++ op ++ "'" + | _op == iNot = test (t == TBoolean) >> return TBoolean + | _op == iCSet = return TInteger + | _op == iSumSet = test (t == TInteger) >> return TInteger + | _op `elem` [iMin, iGMin, iGMax] = test (numeric t) >> return t + | otherwise = error $ "Unknown op '" ++ _op ++ "'" result' <- result - return (result', e{exps = [arg']}) + return (result', e{_exps = [arg']}) - resolveTExp e@IFunExp {op = ".", exps = [arg1, arg2]} = + resolveTExp e@IFunExp {_op = ".", _exps = [arg1, arg2]} = do runListT $ runErrorT $ do arg1' <- lift $ ListT $ resolveTPExp arg1 localCurPath (typeOf arg1') $ do arg2' <- liftError $ lift $ ListT $ resolveTPExp arg2 - return (fromJust $ iType arg2', e{exps = [arg1', arg2']}) + return (fromJust $ _iType arg2', e{_exps = [arg1', arg2']}) - resolveTExp e@IFunExp {op = "++", exps = [arg1, arg2]} = + resolveTExp e@IFunExp {_op = "++", _exps = [arg1, arg2]} = do arg1s' <- resolveTPExp arg1 arg2s' <- resolveTPExp arg2 let union' a b = typeOf a +++ typeOf b - return $ [return (union' arg1' arg2', e{exps = [arg1', arg2']}) | (arg1', arg2') <- sortBy (comparing $ length . unionType . uncurry union') $ liftM2 (,) arg1s' arg2s'] - resolveTExp e@IFunExp {op, exps = [arg1, arg2]} = + return $ [return (union' arg1' arg2', e{_exps = [arg1', arg2']}) | (arg1', arg2') <- sortBy (comparing $ length . unionType . uncurry union') $ liftM2 (,) arg1s' arg2s'] + resolveTExp e@IFunExp {_op, _exps = [arg1, arg2]} = runListT $ runErrorT $ do arg1' <- lift $ ListT $ resolveTPExp arg1 arg2' <- lift $ ListT $ resolveTPExp arg2 @@ -321,29 +321,29 @@ it <- intersection e1 e2 case it of Just it' -> return it' - Nothing -> throwError $ SemanticErr inPos ("Function '" ++ op ++ "' cannot be performed on '" ++ str t1 ++ "' " ++ op ++ " '" ++ str t2 ++ "'") + Nothing -> throwError $ SemanticErr _inPos ("Function '" ++ _op ++ "' cannot be performed on '" ++ str t1 ++ "' " ++ _op ++ " '" ++ str t2 ++ "'") let testNotSame e1 e2 = when (e1 `sameAs` e2) $ - throwError $ SemanticErr inPos ("Function '" ++ op ++ "' is redundant because the two subexpressions are always equivalent") + throwError $ SemanticErr _inPos ("Function '" ++ _op ++ "' is redundant because the two subexpressions are always equivalent") let test c = unless c $ - throwError $ SemanticErr inPos ("Function '" ++ op ++ "' cannot be performed on '" ++ str t1 ++ "' " ++ op ++ " '" ++ str t2 ++ "'") + throwError $ SemanticErr _inPos ("Function '" ++ _op ++ "' cannot be performed on '" ++ str t1 ++ "' " ++ _op ++ " '" ++ str t2 ++ "'") let result - | op `elem` logBinOps = test (t1 == TBoolean && t2 == TBoolean) >> return TBoolean - | op `elem` [iLt, iGt, iLte, iGte] = test (numeric t1 && numeric t2) >> return TBoolean - | op `elem` [iEq, iNeq] = testNotSame arg1' arg2' >> testIntersect t1 t2 >> return TBoolean - | op == iDifference = testNotSame arg1' arg2' >> testIntersect t1 t2 >> return t1 - | op == iIntersection = testNotSame arg1' arg2' >> testIntersect t1 t2 - | op `elem` [iDomain, iRange] = testIntersect t1 t2 - | op `elem` relSetBinOps = testIntersect t1 t2 >> return TBoolean - | op `elem` [iSub, iMul, iDiv] = test (numeric t1 && numeric t2) >> return (coerce t1 t2) - | op == iPlus = + | _op `elem` logBinOps = test (t1 == TBoolean && t2 == TBoolean) >> return TBoolean + | _op `elem` [iLt, iGt, iLte, iGte] = test (numeric t1 && numeric t2) >> return TBoolean + | _op `elem` [iEq, iNeq] = testNotSame arg1' arg2' >> testIntersect t1 t2 >> return TBoolean + | _op == iDifference = testNotSame arg1' arg2' >> testIntersect t1 t2 >> return t1 + | _op == iIntersection = testNotSame arg1' arg2' >> testIntersect t1 t2 + | _op `elem` [iDomain, iRange] = testIntersect t1 t2 + | _op `elem` relSetBinOps = testIntersect t1 t2 >> return TBoolean + | _op `elem` [iSub, iMul, iDiv] = test (numeric t1 && numeric t2) >> return (coerce t1 t2) + | _op == iPlus = (test (t1 == TString && t2 == TString) >> return TString) -- Case 1: String concatenation `catchError` const (test (numeric t1 && numeric t2) >> return (coerce t1 t2)) -- Case 2: Addition | otherwise = error $ "Unknown op: " ++ show e result' <- result - return (result', e{exps = [arg1', arg2']}) + return (result', e{_exps = [arg1', arg2']}) resolveTExp e@(IFunExp "=>else" [arg1, arg2, arg3]) = runListT $ runErrorT $ do @@ -357,27 +357,27 @@ -- throwError $ SemanticErr inPos ("The types are: '" ++ str t2 ++ "' and '" ++ str t3 ++ "'") unless (t1 == TBoolean) $ - throwError $ SemanticErr inPos ("Function 'if/else' cannot be performed on 'if' " ++ str t1 ++ " 'then' " ++ str t2 ++ " 'else' " ++ str t3) + throwError $ SemanticErr _inPos ("Function 'if/else' cannot be performed on 'if' " ++ str t1 ++ " 'then' " ++ str t2 ++ " 'else' " ++ str t3) it <- getIfThenElseType t2 t3 t <- case it of Just it' -> return it' - Nothing -> throwError $ SemanticErr inPos ("Function '=>else' cannot be performed on if '" ++ str t1 ++ "' then '" ++ str t2 ++ "' else '" ++ str t3 ++ "'") + Nothing -> throwError $ SemanticErr _inPos ("Function '=>else' cannot be performed on if '" ++ str t1 ++ "' then '" ++ str t2 ++ "' else '" ++ str t3 ++ "'") - return (t, e{exps = [arg1', arg2', arg3']}) + return (t, e{_exps = [arg1', arg2', arg3']}) - resolveTExp e@IDeclPExp{oDecls, bpexp} = + resolveTExp e@IDeclPExp{_oDecls, _bpexp} = runListT $ runErrorT $ do - oDecls' <- mapM resolveTDecl oDecls - let extraDecls = [(decl, typeOf $ body oDecl) | oDecl <- oDecls', decl <- decls oDecl] + oDecls' <- mapM resolveTDecl _oDecls + let extraDecls = [(decl, typeOf $ _body oDecl) | oDecl <- oDecls', decl <- _decls oDecl] localDecls extraDecls $ do - bpexp' <- liftError $ lift $ ListT $ resolveTPExp bpexp - return $ (TBoolean, e{oDecls = oDecls', bpexp = bpexp'}) + bpexp' <- liftError $ lift $ ListT $ resolveTPExp _bpexp + return $ (TBoolean, e{_oDecls = oDecls', _bpexp = bpexp'}) where - resolveTDecl d@IDecl{body} = + resolveTDecl d@IDecl{_body} = do - body' <- lift $ ListT $ resolveTPExp body - return $ d{body = body'} + body' <- lift $ ListT $ resolveTPExp _body + return $ d{_body = body'} resolveTExp e = error $ "Unknown iexp: " ++ show e @@ -390,13 +390,13 @@ let result = (newPExp $ IFunExp "." [pexp, deref]) `withType` typeOf deref return result <++> addRef result where - newPExp = PExp Nothing "" $ inPos pexp + newPExp = PExp Nothing "" $ _inPos pexp typeOf :: PExp -> IType -typeOf pexp = fromMaybe (error "No type") $ iType pexp +typeOf pexp = fromMaybe (error "No type") $ _iType pexp withType :: PExp -> IType -> PExp -withType p t = p{iType = Just t} +withType p t = p{_iType = Just t} (<++>) :: (Error e, MonadPlus m) => ErrorT e m a -> ErrorT e m a -> ErrorT e m a (ErrorT a) <++> (ErrorT b) = ErrorT $ a `mplus` b diff --git a/src/Language/Clafer/Intermediate/SimpleScopeAnalyzer.hs b/src/Language/Clafer/Intermediate/SimpleScopeAnalyzer.hs --- a/src/Language/Clafer/Intermediate/SimpleScopeAnalyzer.hs +++ b/src/Language/Clafer/Intermediate/SimpleScopeAnalyzer.hs @@ -1,5 +1,5 @@ {- - Copyright (C) 2012-2014 Jimmy Liang, Kacper Bak + Copyright (C) 2012-2014 Jimmy Liang, Kacper Bak, Michał Antkiewicz Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in @@ -22,6 +22,7 @@ module Language.Clafer.Intermediate.SimpleScopeAnalyzer (simpleScopeAnalysis) where import Language.Clafer.Common +import Control.Lens hiding (elements, assign) import Data.Graph import Data.List import Data.Map (Map) @@ -34,24 +35,22 @@ isReference :: IClafer -> Bool -isReference = isOverlapping . super +isReference = _isOverlapping . _super isConcrete :: IClafer -> Bool isConcrete = not . isReference isSuperest :: [IClafer] -> IClafer -> Bool isSuperest clafers clafer = isNothing $ directSuper clafers clafer --- Collects the global cardinality and hierarchy information into proper lower bounds. --- If the model only has Clafers (ie. no constraints) then the lower bound is tight. --- scopeAnalysis :: IModule -> Map IClafer Integer +-- | Collects the global cardinality and hierarchy information into proper, not necessarily lower, bounds. simpleScopeAnalysis :: IModule -> [(String, Integer)] -simpleScopeAnalysis IModule{mDecls = decls'} = - [(a, b) | (a, b) <- finalAnalysis, isReferenceOrSuper a, b /= 0] +simpleScopeAnalysis IModule{_mDecls = decls'} = + [(a, b) | (a, b) <- finalAnalysis, isReferenceOrSuper a, b /= 1] where - finalAnalysis = Map.toList $ foldl analyzeComponent supersAnalysis connectedComponents + finalAnalysis = Map.toList $ foldl analyzeComponent supersAndRefsAnalysis connectedComponents isReferenceOrSuper uid' = - isReference clafer || isSuperest clafers clafer + isConcrete clafer || isReference clafer || isSuperest clafers clafer where clafer = findClafer uid' @@ -59,9 +58,10 @@ upperCards u = Map.findWithDefault (error $ "No upper cardinality for clafer named \"" ++ u ++ "\".") u upperCardsMap - upperCardsMap = Map.fromList [(uid c, snd $ fromJust $ card c) | c <- clafers] + upperCardsMap = Map.fromList [(_uid c, snd $ fromJust $ _card c) | c <- clafers] supersAnalysis = foldl (analyzeSupers clafers) Map.empty decls' + supersAndRefsAnalysis = foldl (analyzeRefs clafers) supersAnalysis decls' constraintAnalysis = analyzeConstraints constraints upperCards (subclaferMap, parentMap) = analyzeHierarchy clafers connectedComponents = analyzeDependencies clafers @@ -69,11 +69,17 @@ constraints = concatMap findConstraints decls' findClafer uid' = fromJust $ find (isEqClaferId uid') clafers - lowCard clafer = - max low constraintLow + lowerOrUpperFixedCard analysis' clafer = + maximum [cardLb, cardUb, lowFromConstraints, oneForStar, targetScopeForStar ] where - low = fst $ fromJust $ card clafer - constraintLow = Map.findWithDefault 0 (uid clafer) constraintAnalysis + Just (cardLb, cardUb) = _card clafer + oneForStar = if (cardLb == 0 && cardUb == -1) then 1 else 0 + targetScopeForStar = if (isReference clafer && cardUb == -1) + then case (directSuper clafers clafer) of + (Just targetClafer) -> Map.findWithDefault 0 (_uid targetClafer) analysis' + Nothing -> 0 + else 0 + lowFromConstraints = Map.findWithDefault 0 (_uid clafer) constraintAnalysis analyzeComponent analysis' component = case flattenSCC component of @@ -87,44 +93,59 @@ analyzeSingleton uid' analysis'' = analyze analysis'' $ findClafer uid' analyze :: Map String Integer -> IClafer -> Map String Integer - analyze analysis clafer = - -- Take the max between the reference analysis and this analysis - Map.insertWith max (uid clafer) scope analysis + analyze analysis' clafer = + -- Take the max between the supers and references analysis and this analysis + Map.insertWith max (_uid clafer) scope analysis' where scope - | isAbstract clafer = sum subclaferScopes - | otherwise = parentScope * lowCard clafer + | _isAbstract clafer = sum subclaferScopes + | otherwise = parentScope * (lowerOrUpperFixedCard analysis' clafer) - subclaferScopes = map (findOrError " subclafer scope not found" analysis) $ filter isConcrete' subclafers + subclaferScopes = map (findOrError " subclafer scope not found" analysis') $ filter isConcrete' subclafers parentScope = - case parent' of - Just parent'' -> findOrError " parent scope not found" analysis parent'' + case parentMaybe of + Just parent'' -> findOrError " parent scope not found" analysis' parent'' Nothing -> rootScope - subclafers = Map.findWithDefault [] (uid clafer) subclaferMap - parent' = Map.lookup (uid clafer) parentMap + subclafers = Map.findWithDefault [] (_uid clafer) subclaferMap + parentMaybe = Map.lookup (_uid clafer) parentMap rootScope = 1 findOrError message m key = Map.findWithDefault (error $ key ++ message) key m analyzeSupers :: [IClafer] -> Map String Integer -> IElement -> Map String Integer analyzeSupers clafers analysis (IEClafer clafer) = - foldl (analyzeSupers clafers) analysis' (elements clafer) + foldl (analyzeSupers clafers) analysis' (_elements clafer) where - lowerBound = max 1 $ fst (fromJust $ card clafer) - analysis' = case (directSuper clafers clafer) of - (Just c) -> Map.alter ((if isReference clafer then maxLB else incLB) lowerBound) (uid c) analysis - Nothing -> analysis + (Just (cardLb, cardUb)) = _card clafer + lowerOrFixedUpperBound = maximum [1, cardLb, cardUb ] + analysis' = if (isReference clafer) + then analysis + else case (directSuper clafers clafer) of + (Just c) -> Map.alter (incLB lowerOrFixedUpperBound) (_uid c) analysis + Nothing -> analysis incLB lb' Nothing = Just lb' incLB lb' (Just lb) = Just (lb + lb') - maxLB lb' Nothing = Just lb' - maxLB lb' (Just lb) = Just (max lb lb') analyzeSupers _ analysis _ = analysis +analyzeRefs :: [IClafer] -> Map String Integer -> IElement -> Map String Integer +analyzeRefs clafers analysis (IEClafer clafer) = + foldl (analyzeRefs clafers) analysis' (_elements clafer) + where + (Just (cardLb, cardUb)) = _card clafer + lowerOrFixedUpperBound = maximum [1, cardLb, cardUb] + analysis' = if (isReference clafer) + then case (directSuper clafers clafer) of + (Just c) -> Map.alter (maxLB lowerOrFixedUpperBound) (_uid c) analysis + Nothing -> analysis + else analysis + maxLB lb' Nothing = Just lb' + maxLB lb' (Just lb) = Just (max lb lb') +analyzeRefs _ analysis _ = analysis analyzeConstraints :: [PExp] -> (String -> Integer) -> Map String Integer analyzeConstraints constraints upperCards = foldr analyzeConstraint Map.empty $ filter isOneOrSomeConstraint constraints where - isOneOrSomeConstraint PExp{exp = IDeclPExp{quant = quant'}} = + isOneOrSomeConstraint PExp{_exp = IDeclPExp{_quant = quant'}} = -- Only these two quantifiers requires an increase in scope to satisfy. case quant' of IOne -> True @@ -134,18 +155,18 @@ -- Only considers how quantifiers affect scope. Other types of constraints are not considered. -- Constraints of the type [some path1.path2] or [no path1.path2], etc. - analyzeConstraint PExp{exp = IDeclPExp{oDecls = [], bpexp = bpexp'}} analysis = + analyzeConstraint PExp{_exp = IDeclPExp{_oDecls = [], _bpexp = bpexp'}} analysis = foldr atLeastOne analysis path' where path' = dropThisAndParent $ unfoldJoins bpexp' atLeastOne = Map.insertWith max `flip` 1 -- Constraints of the type [all disj a : path1.path2] or [some b : path3.path4], etc. - analyzeConstraint PExp{exp = IDeclPExp{oDecls = decls'}} analysis = + analyzeConstraint PExp{_exp = IDeclPExp{_oDecls = decls'}} analysis = foldr analyzeDecl analysis decls' analyzeConstraint _ analysis = analysis - analyzeDecl IDecl{isDisj = isDisj', decls = decls', body = body'} analysis = + analyzeDecl IDecl{_isDisj = isDisj', _decls = decls', _body = body'} analysis = foldr (uncurry insert') analysis $ zip path' scores where -- Take the first element in the path', and change its effective lower cardinality. @@ -219,16 +240,16 @@ where -- This is to make the "stronglyConnComp" from Data.Graph play nice. Otherwise, -- clafers with no dependencies will not appear in the result. - selfDependency = (uid clafer, uid clafer) + selfDependency = (_uid clafer, _uid clafer) superDependency | isReference clafer = Nothing | otherwise = do super' <- directSuper clafers clafer -- Need to analyze clafer before its super - return (uid super', uid clafer) + return (_uid super', _uid clafer) -- Need to analyze clafer before its children - childDependencies = [(uid child, uid clafer) | child <- childClafers clafer] + childDependencies = [(_uid child, _uid clafer) | child <- childClafers clafer] analyzeHierarchy :: [IClafer] -> (Map String [String], Map String String) @@ -239,10 +260,10 @@ where subclaferMap' = case super' of - Just super'' -> Map.insertWith (++) (uid super'') [uid clafer] subclaferMap + Just super'' -> Map.insertWith (++) (_uid super'') [_uid clafer] subclaferMap Nothing -> subclaferMap super' = directSuper clafers clafer - parentMap' = foldr (flip Map.insert $ uid clafer) parentMap (map uid $ childClafers clafer) + parentMap' = foldr (flip Map.insert $ _uid clafer) parentMap (map _uid $ childClafers clafer) directSuper :: [IClafer] -> IClafer -> Maybe IClafer directSuper clafers clafer = @@ -255,24 +276,19 @@ -- Finds all ancestors findClafers :: IElement -> [IClafer] -findClafers (IEClafer clafer) = clafer : concatMap findClafers (elements clafer) +findClafers (IEClafer clafer) = clafer : concatMap findClafers (_elements clafer) findClafers _ = [] -- Find all constraints findConstraints :: IElement -> [PExp] -findConstraints IEConstraint{cpexp = c} = [c] -findConstraints (IEClafer clafer) = concatMap findConstraints (elements clafer) +findConstraints IEConstraint{_cpexp = c} = [c] +findConstraints (IEClafer clafer) = concatMap findConstraints (_elements clafer) findConstraints _ = [] -- Finds all the direct ancestors (ie. children) childClafers :: IClafer -> [IClafer] -childClafers clafer = - mapMaybe asClafer (elements clafer) - where - asClafer (IEClafer claf) = Just claf - asClafer _ = Nothing - +childClafers clafer = clafer ^.. elements.traversed.iClafer -- Unfold joins -- If the expression is a tree of only joins, then this function will flatten @@ -282,9 +298,9 @@ unfoldJoins pexp = fromMaybe [] $ unfoldJoins' pexp where - unfoldJoins' PExp{exp = (IFunExp "." args)} = + unfoldJoins' PExp{_exp = (IFunExp "." args)} = return $ args >>= unfoldJoins - unfoldJoins' PExp{exp = IClaferId{sident = sident'}} = + unfoldJoins' PExp{_exp = IClaferId{_sident = sident'}} = return $ [sident'] unfoldJoins' _ = fail "not a join" diff --git a/src/Language/Clafer/Intermediate/StringAnalyzer.hs b/src/Language/Clafer/Intermediate/StringAnalyzer.hs --- a/src/Language/Clafer/Intermediate/StringAnalyzer.hs +++ b/src/Language/Clafer/Intermediate/StringAnalyzer.hs @@ -33,9 +33,9 @@ -- | Convert all strings into ints for analysis -- | Return an inverse map from ints back to strings astrModule :: IModule -> (IModule, Map Int String) -astrModule imodule = (imodule{mDecls = decls''}, flipMap strMap') +astrModule imodule = (imodule{_mDecls = decls''}, flipMap strMap') where - decls' = mDecls imodule + decls' = _mDecls imodule (decls'', strMap') = runState (mapM astrElement decls') Map.empty flipMap :: Map String Int -> Map Int String @@ -80,6 +80,6 @@ concatStrExp x = case x of IFunExp _ exps' -> IStr $ s0 ++ s1 where - ((IStr s0):(IStr s1):_) = map concatStrExp $ map (Language.Clafer.Intermediate.Intclafer.exp) exps' + ((IStr s0):(IStr s1):_) = map concatStrExp $ map (Language.Clafer.Intermediate.Intclafer._exp) exps' IStr _ -> x _ -> x diff --git a/src/Language/Clafer/Intermediate/Tracing.hs b/src/Language/Clafer/Intermediate/Tracing.hs --- a/src/Language/Clafer/Intermediate/Tracing.hs +++ b/src/Language/Clafer/Intermediate/Tracing.hs @@ -33,8 +33,8 @@ insert :: Span -> Ir -> Map Span [Ir] -> Map Span [Ir] insert k a = Map.insertWith (++) k [a] getMap :: Ir -> Map Span [Ir] --Map Span [Union (IRClafer IClafer) (IRPExp PExp)] - getMap (IRPExp (p@PExp{inPos = s})) = insert s (IRPExp p) Map.empty - getMap (IRClafer (c@IClafer{cinPos = s})) = insert s (IRClafer c) Map.empty + getMap (IRPExp (p@PExp{_inPos = s})) = insert s (IRPExp p) Map.empty + getMap (IRClafer (c@IClafer{_cinPos = s})) = insert s (IRClafer c) Map.empty getMap _ = Map.empty traceAstModule :: Module -> Map Span [Ast] diff --git a/src/Language/Clafer/Intermediate/Transformer.hs b/src/Language/Clafer/Intermediate/Transformer.hs --- a/src/Language/Clafer/Intermediate/Transformer.hs +++ b/src/Language/Clafer/Intermediate/Transformer.hs @@ -21,32 +21,34 @@ -} module Language.Clafer.Intermediate.Transformer where +import Control.Lens import Data.Maybe import Language.Clafer.Common -import Language.Clafer.Intermediate.Intclafer +import qualified Language.Clafer.Intermediate.Intclafer as I (exp, elements, op) +import Language.Clafer.Intermediate.Intclafer hiding (exp, elements, op) import Language.Clafer.Intermediate.Desugarer transModule :: IModule -> IModule -transModule imodule = imodule{mDecls = map transElement $ mDecls imodule} +transModule = mDecls . traversed %~ transElement transElement :: IElement -> IElement -transElement x = case x of - IEClafer clafer -> IEClafer $ transClafer clafer - IEConstraint isHard' pexp -> IEConstraint isHard' $ transPExp False pexp - IEGoal isMaximize' pexp -> IEGoal isMaximize' $ transPExp False pexp +transElement (IEClafer clafer) = IEClafer $ transClafer clafer +transElement (IEConstraint isHard' pexp) = IEConstraint isHard' $ transPExp False pexp +transElement (IEGoal isMaximize' pexp) = IEGoal isMaximize' $ transPExp False pexp transClafer :: IClafer -> IClafer -transClafer clafer = clafer{elements = map transElement $ elements clafer} +transClafer = I.elements . traversed %~ transElement transPExp :: Bool -> PExp -> PExp -transPExp some (PExp t pid' pos' x) = trans $ PExp t pid' pos' $ transIExp (fromJust t) x - where - trans = if some then desugarPath else id +transPExp True pexp'@(PExp iType' _ _ _) = desugarPath $ I.exp %~ transIExp (fromJust $ iType') $ pexp' +transPExp False pexp' = pexp' transIExp :: IType -> IExp -> IExp -transIExp t x = case x of - IDeclPExp quant' decls' pexp -> IDeclPExp quant' decls' $ transPExp False pexp - IFunExp op' exps' -> IFunExp op' $ map (transPExp cond) exps' - where - cond = op' == iIfThenElse && t `elem` [TBoolean, TClafer []] - _ -> x +transIExp iType' idpe@(IDeclPExp _ _ _) = bpexp %~ transPExp False $ idpe +transIExp iType' ife@(IFunExp op' _) = exps . traversed %~ transPExp cond $ ife + where + cond = op' == iIfThenElse && + iType' `elem` [TBoolean, TClafer []] +transIExp _ iexp' = iexp' + + diff --git a/src/Language/Clafer/JSONMetaData.hs b/src/Language/Clafer/JSONMetaData.hs --- a/src/Language/Clafer/JSONMetaData.hs +++ b/src/Language/Clafer/JSONMetaData.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} {- Copyright (C) 2014 Michal Antkiewicz @@ -22,15 +23,23 @@ -- | Creates JSON outputs for different kinds of metadata. module Language.Clafer.JSONMetaData ( generateJSONnameUIDMap, - generateJSONScopes + generateJSONScopes, + parseJSONScopes, + writeCfrScopeFile, + readCfrScopeFile ) where +import Control.Lens hiding (element) +import Data.Aeson.Lens import qualified Data.List as List import Data.Maybe import Data.Json.Builder import Data.String.Conversions +import qualified Data.Text as T +import System.FilePath +import System.Directory import Language.Clafer.QNameUID @@ -46,9 +55,9 @@ generateQNameUIDArrayEntry :: Array -> (FQName, PQName, UID) -> Array generateQNameUIDArrayEntry array (fqName, lpqName, uid) = mappend array $ element $ mconcat [ - row "fqName" fqName, - row "lpqName" lpqName, - row "uid" uid ] + row ("fqName" :: String) fqName, + row ("lpqName" :: String) lpqName, + row ("uid" :: String) uid ] -- | Generate a JSON list of tuples containing a least-partially-qualified name and a scope generateJSONScopes :: QNameMaps -> [(UID, Integer)] -> String @@ -63,8 +72,8 @@ generateLpqNameScopeArrayEntry :: Array -> (PQName, Integer) -> Array generateLpqNameScopeArrayEntry array (lpqName, scope) = mappend array $ element $ mconcat [ - row "lpqName" lpqName, - row "scope" scope ] + row ("lpqName" :: String) lpqName, + row ("scope" :: String) scope ] -- insert a new line after [, {, and , prettyPrintJSON :: String -> String @@ -77,3 +86,39 @@ -- just rewrite and continue prettyPrintJSON (c:line) = c:(prettyPrintJSON line) prettyPrintJSON "" = "" + +-- | given the QNameMaps, parse the JSON scopes and return list of scopes +parseJSONScopes :: QNameMaps -> String -> [ (UID, Integer) ] +parseJSONScopes qNameMaps scopesJSON = + foldl (\uidScopes qScope -> (qNameToUIDs qScope) ++ uidScopes) [] decodedScopes + where + -- QName + decodedScopes :: [ (T.Text, Integer) ] + decodedScopes = scopesJSON ^.. _Array . traverse + . to (\o -> ( o ^?! key "lpqName" . _String + , o ^?! key "scope" . _Integer) + ) + -- a QName may resolve to potentially multiple UIDs + qNameToUIDs :: (T.Text, Integer) -> [ (UID, Integer) ] + qNameToUIDs (qName, scope) = if T.null qName + then [ ("", scope) ] + else [ (uid, scope) | uid <- getUIDs qNameMaps $ convertString qName] + +-- | Write a .cfr-scope file +writeCfrScopeFile :: [ (UID, Integer) ] -> QNameMaps -> FilePath -> IO () +writeCfrScopeFile uidScopes qNameMaps modelName = do + let + scopesInJSON = generateJSONScopes qNameMaps uidScopes + writeFile (replaceExtension modelName ".cfr-scope") scopesInJSON + +-- | Read a .cfr-scope file +readCfrScopeFile :: QNameMaps -> FilePath -> IO (Maybe [ (UID, Integer) ]) +readCfrScopeFile qNameMaps modelName = do + let + cfrScopeFileName = replaceExtension modelName ".cfr-scope" + exists <- doesFileExist cfrScopeFileName + if exists + then do + scopesInJSON <- readFile cfrScopeFileName + return $ Just $ parseJSONScopes qNameMaps scopesInJSON + else return Nothing diff --git a/src/Language/Clafer/Optimizer/Optimizer.hs b/src/Language/Clafer/Optimizer/Optimizer.hs --- a/src/Language/Clafer/Optimizer/Optimizer.hs +++ b/src/Language/Clafer/Optimizer/Optimizer.hs @@ -24,18 +24,21 @@ import Data.Maybe import Data.List +import Control.Lens hiding (elements, children, un) import Control.Monad.State +import Data.Data.Lens (biplate) import qualified Data.Map as Map import Language.Clafer.Common import Language.Clafer.ClaferArgs import Language.Clafer.Intermediate.Intclafer +import Language.ClaferT (ClaferErr, CErr(..)) -- | Apply optimizations for unused abstract clafers and inheritance flattening optimizeModule :: ClaferArgs -> (IModule, GEnv) -> IModule optimizeModule args (imodule, genv) = - imodule{mDecls = em $ rm $ map (optimizeElement (1, 1)) $ - markTopModule $ mDecls imodule} + imodule{_mDecls = em $ rm $ map (optimizeElement (1, 1)) $ + markTopModule $ _mDecls imodule} where rm = if keep_unused args then makeZeroUnusedAbs else remUnusedAbs em = if flatten_inheritance args then flip (curry expModule) genv else id @@ -47,10 +50,10 @@ IEGoal _ _ -> x optimizeClafer :: Interval -> IClafer -> IClafer -optimizeClafer interval' c = c {glCard = glCard', - elements = map (optimizeElement glCard') $ elements c} +optimizeClafer interval' c = c {_glCard = glCard', + _elements = map (optimizeElement glCard') $ _elements c} where - glCard' = multInt (fromJust $ card c) interval' + glCard' = multInt (fromJust $ _card c) interval' multInt :: Interval -> Interval -> Interval @@ -64,10 +67,10 @@ -- ----------------------------------------------------------------------------- makeZeroUnusedAbs :: [IElement] -> [IElement] -makeZeroUnusedAbs decls' = map (\x -> if (x `elem` unusedAbs) then IEClafer (getIClafer x){card = Just (0, 0)} else x) decls' +makeZeroUnusedAbs decls' = map (\x -> if (x `elem` unusedAbs) then IEClafer (getIClafer x){_card = Just (0, 0)} else x) decls' where - unusedAbs = map IEClafer $ findUnusedAbs clafers $ map uid $ - filter (not.isAbstract) clafers + unusedAbs = map IEClafer $ findUnusedAbs clafers $ map _uid $ + filter (not._isAbstract) clafers clafers = toClafers decls' getIClafer (IEClafer c) = c getIClafer _ = error "Function makeZeroUnusedAbs from Optimizer expected paramter of type IClafer got a differnt IElement" --This should never happen @@ -75,8 +78,8 @@ remUnusedAbs :: [IElement] -> [IElement] remUnusedAbs decls' = decls' \\ unusedAbs where - unusedAbs = map IEClafer $ findUnusedAbs clafers $ map uid $ - filter (not.isAbstract) clafers + unusedAbs = map IEClafer $ findUnusedAbs clafers $ map _uid $ + filter (not._isAbstract) clafers clafers = toClafers decls' @@ -85,7 +88,7 @@ findUnusedAbs [] _ = [] findUnusedAbs maybeUsed used = findUnusedAbs maybeUsed' $ getUniqExtended used' where - (used', maybeUsed') = partition (\c -> uid c `elem` used) maybeUsed + (used', maybeUsed') = partition (\c -> _uid c `elem` used) maybeUsed getUniqExtended :: [IClafer] -> [String] getUniqExtended used = nub $ used >>= getExtended @@ -93,9 +96,9 @@ getExtended :: IClafer -> [String] getExtended c = - sName ++ ((getSubclafers $ elements c) >>= getExtended) + sName ++ ((getSubclafers $ _elements c) >>= getExtended) where - sName = if not $ isOverlapping $ super c then [getSuper c] else [] + sName = if not $ _isOverlapping $ _super c then [getSuper c] else [] -- ----------------------------------------------------------------------------- -- inheritance expansions @@ -105,9 +108,9 @@ expClafer :: MonadState GEnv m => IClafer -> m IClafer expClafer claf = do - super' <- expSuper $ super claf - elements' <- mapM expElement $ elements claf - return $ claf {super = super', elements = elements'} + super' <- expSuper $ _super claf + elements' <- mapM expElement $ _elements claf + return $ claf {_super = super', _elements = elements'} expSuper :: MonadState GEnv m => ISuper -> m ISuper expSuper x = case x of @@ -146,10 +149,10 @@ expNav' :: MonadState GEnv m => String -> IExp -> m (IExp, String) expNav' context (IFunExp _ (p0:p:_)) = do - (exp0', context') <- expNav' context $ Language.Clafer.Intermediate.Intclafer.exp p0 - (exp', context'') <- expNav' context' $ Language.Clafer.Intermediate.Intclafer.exp p - return (IFunExp iJoin [ p0 {Language.Clafer.Intermediate.Intclafer.exp = exp0'} - , p {Language.Clafer.Intermediate.Intclafer.exp = exp'}], context'') + (exp0', context') <- expNav' context $ _exp p0 + (exp', context'') <- expNav' context' $ _exp p + return (IFunExp iJoin [ p0 {_exp = exp0'} + , p {_exp = exp'}], context'') expNav' context x@(IClaferId modName' id' isTop') = do st <- gets stable if Map.member id' st @@ -166,8 +169,8 @@ split' :: MonadState GEnv m => IExp -> (IExp -> m IExp) -> m [IExp] split'(IFunExp _ (p:pexp:_)) f = - split' (Language.Clafer.Intermediate.Intclafer.exp p) (\s -> f $ IFunExp iJoin - [p {Language.Clafer.Intermediate.Intclafer.exp = s}, pexp]) + split' (_exp p) (\s -> f $ IFunExp iJoin + [p {_exp = s}, pexp]) split' (IClaferId modName' id' isTop') f = do st <- gets stable mapM f $ map (\y -> IClaferId modName' y isTop') $ maybe [id'] (map head) $ Map.lookup id' st @@ -180,15 +183,15 @@ allUnique imodule = and un && (null $ filter (\xs -> 1 < length xs) $ group $ sort $ concat idents) && identsOk where - (un, idents) = unzip $ map allUniqueElement $ mDecls imodule - identsOk = and $ map (checkConstraintElement (concat idents)) $ mDecls imodule + (un, idents) = unzip $ map allUniqueElement $ _mDecls imodule + identsOk = and $ map (checkConstraintElement (concat idents)) $ _mDecls imodule allUniqueClafer :: IClafer -> (Bool, [String]) allUniqueClafer claf = (getSuper claf `elem` "clafer" : primitiveTypes && and un, - ident claf : concat idents) + _ident claf : concat idents) where - (un, idents) = unzip $ map allUniqueElement $ elements claf + (un, idents) = unzip $ map allUniqueElement $ _elements claf allUniqueElement :: IElement -> (Bool, [String]) allUniqueElement x = case x of @@ -198,13 +201,12 @@ checkConstraintElement :: [String] -> IElement -> Bool checkConstraintElement idents x = case x of - IEClafer claf -> and $ map (checkConstraintElement idents) $ elements claf + IEClafer claf -> and $ map (checkConstraintElement idents) $ _elements claf IEConstraint _ pexp -> checkConstraintPExp idents pexp IEGoal _ _ -> True checkConstraintPExp :: [String] -> PExp -> Bool -checkConstraintPExp idents pexp = checkConstraintIExp idents $ - Language.Clafer.Intermediate.Intclafer.exp pexp +checkConstraintPExp idents pexp = checkConstraintIExp idents $ _exp pexp checkConstraintIExp :: [String] -> IExp -> Bool checkConstraintIExp idents x = case x of @@ -220,39 +222,18 @@ | otherwise = [] -- ----------------------------------------------------------------------------- -findDupModule :: ClaferArgs -> IModule -> IModule -findDupModule args imodule = imodule{mDecls = decls'} - where - decls'' = mDecls imodule - decls' - | check_duplicates args = findDupModule' decls'' - | otherwise = decls'' - - -findDupModule' :: [IElement] -> [IElement] -findDupModule' declarations - | null dups = map findDupElement declarations - | otherwise = error $ show dups - where - dups = findDuplicates $ toClafers declarations - -findDupClafer :: IClafer -> IClafer -findDupClafer claf = if null dups - then claf{elements = map findDupElement $ elements claf} - else error $ (show $ ident claf) ++ show dups - where - dups = findDuplicates $ getSubclafers $ elements claf - -findDupElement :: IElement -> IElement -findDupElement x = case x of - IEClafer claf -> IEClafer $ findDupClafer claf - IEConstraint _ _ -> x - IEGoal _ _ -> x - +findDupModule :: ClaferArgs -> IModule -> Either ClaferErr IModule +findDupModule args iModule = if check_duplicates args && (not $ null dups) + then Left $ ClaferErr $ "--check-duplicates: Duplicate clafer names: " ++ (intercalate ", " dups) + else Right iModule + where + allClafers :: [ IClafer ] + allClafers = universeOn biplate iModule + dups = findDuplicates allClafers -findDuplicates :: [IClafer] -> [String] -findDuplicates clafers = - map head $ filter (\xs -> 1 < length xs) $ group $ sort $ map ident clafers + findDuplicates :: [IClafer] -> [String] + findDuplicates clafers = + map head $ filter (\xs -> 1 < length xs) $ group $ sort $ map _ident clafers -- ----------------------------------------------------------------------------- -- marks top clafers @@ -260,17 +241,17 @@ markTopModule :: [IElement] -> [IElement] markTopModule decls' = map (markTopElement ( [this, parent, children, strType, intType, integerType] ++ - (map uid $ toClafers decls'))) decls' + (map _uid $ toClafers decls'))) decls' markTopClafer :: [String] -> IClafer -> IClafer markTopClafer clafers c = - c {super = markTopSuper clafers $ super c, - elements = map (markTopElement clafers) $ elements c} + c {_super = markTopSuper clafers $ _super c, + _elements = map (markTopElement clafers) $ _elements c} markTopSuper :: [String] -> ISuper -> ISuper -markTopSuper clafers x = x{supers = map (markTopPExp clafers) $ supers x} +markTopSuper clafers x = x{_supers = map (markTopPExp clafers) $ _supers x} markTopElement :: [String] -> IElement -> IElement @@ -281,14 +262,13 @@ markTopPExp :: [String] -> PExp -> PExp markTopPExp clafers pexp = - pexp {Language.Clafer.Intermediate.Intclafer.exp = markTopIExp clafers $ - Language.Clafer.Intermediate.Intclafer.exp pexp} + pexp {_exp = markTopIExp clafers $ _exp pexp} markTopIExp :: [String] -> IExp -> IExp markTopIExp clafers x = case x of IDeclPExp quant' decl pexp -> IDeclPExp quant' (map (markTopDecl clafers) decl) - (markTopPExp ((decl >>= decls) ++ clafers) pexp) + (markTopPExp ((decl >>= _decls) ++ clafers) pexp) IFunExp op' exps' -> IFunExp op' $ map (markTopPExp clafers) exps' IClaferId modName' sident' _ -> IClaferId modName' sident' $ sident' `elem` clafers diff --git a/src/Language/Clafer/QNameUID.hs b/src/Language/Clafer/QNameUID.hs --- a/src/Language/Clafer/QNameUID.hs +++ b/src/Language/Clafer/QNameUID.hs @@ -87,23 +87,23 @@ QNameMaps fqNameUIDMap uidFqNameMap uidLpqNameMap deriveFQNameUIDMaps :: IModule -> (FQNameUIDMap, UIDFqNameMap) -deriveFQNameUIDMaps iModule = addElements ["::"] (mDecls iModule) (SMap.empty, Map.empty) +deriveFQNameUIDMaps iModule = addElements ["::"] (_mDecls iModule) (SMap.empty, Map.empty) addElements :: [String] -> [IElement] -> (FQNameUIDMap, UIDFqNameMap) -> (FQNameUIDMap, UIDFqNameMap) addElements path elems maps = foldl (addClafer path) maps elems addClafer :: [String] -> (FQNameUIDMap, UIDFqNameMap) -> IElement -> (FQNameUIDMap, UIDFqNameMap) -addClafer path (fqNameUIDMap, uidFqNameMap) (IEClafer iClafer) = +addClafer path (fqNameUIDMap, uidFqNameMap) (IEClafer iClaf) = let - newPath = (ident iClafer) : path + newPath = (_ident iClaf) : path fqKey :: FQKey fqKey = concat newPath fqName :: FQName fqName = getQNameFromKey fqKey - fqNameUIDMap' = SMap.insert fqKey (uid iClafer) fqNameUIDMap - uidFqNameMap' = Map.insert (uid iClafer) fqName uidFqNameMap + fqNameUIDMap' = SMap.insert fqKey (_uid iClaf) fqNameUIDMap + uidFqNameMap' = Map.insert (_uid iClaf) fqName uidFqNameMap in - addElements ("::" : newPath) (elements iClafer) (fqNameUIDMap', uidFqNameMap') + addElements ("::" : newPath) (_elements iClaf) (fqNameUIDMap', uidFqNameMap') addClafer _ maps _ = maps findUIDsByFQName :: FQNameUIDMap -> FQName -> [ UID ] @@ -119,10 +119,9 @@ getQNameFromKey :: FQKey -> QName getQNameFromKey = reverseOnQualifier - deriveUidLpqNameMap :: FQNameUIDMap -> UIDLpqNameMap deriveUidLpqNameMap fqNameUIDMap = - SMap.foldWithKey (generateUIDLpqMapEntry fqNameUIDMap) Map.empty fqNameUIDMap + SMap.foldrWithKey (generateUIDLpqMapEntry fqNameUIDMap) Map.empty fqNameUIDMap generateUIDLpqMapEntry :: FQNameUIDMap -> SMap.Key -> UID -> UIDLpqNameMap -> UIDLpqNameMap generateUIDLpqMapEntry fqNameUIDMap fqKey uid' uidLpqNameMap = diff --git a/test/Functions.hs b/test/Functions.hs --- a/test/Functions.hs +++ b/test/Functions.hs @@ -41,7 +41,7 @@ compileOneFragment :: ClaferArgs -> InputModel -> Either [ClaferErr] (Map.Map ClaferMode CompilerResult) compileOneFragment args' model = - runClafer args' $ + runClafer (argsWithOPTIONS args' model) $ do addModuleFragment model parse diff --git a/test/Suite/Example.hs b/test/Suite/Example.hs --- a/test/Suite/Example.hs +++ b/test/Suite/Example.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -XTemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} {- Copyright (C) 2013 Luke Brown diff --git a/test/Suite/Negative.hs b/test/Suite/Negative.hs --- a/test/Suite/Negative.hs +++ b/test/Suite/Negative.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -XTemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} {- Copyright (C) 2013 Luke Brown @@ -38,7 +38,7 @@ claferModels <- getClafers "test/negative" return $ filter ((`notElem` crashModels) . fst ) claferModels where - crashModels = ["i127-loop.cfr", "i141-constraints.cfr", "i199-afm-check.cfr"] + crashModels = ["i127-loop.cfr", "i141-constraints.cfr"] {-Put models in the list above that completly crash the compiler, this will avoid crashing the test suite Note: If the model is giving an unexpected error it diff --git a/test/Suite/Positive.hs b/test/Suite/Positive.hs --- a/test/Suite/Positive.hs +++ b/test/Suite/Positive.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -XTemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} {- Copyright (C) 2013 Luke Brown @@ -77,8 +77,8 @@ in [(file', iMod)] getIR (_, _) = [] - isEmptyCard (IRClafer (IClafer{cinPos=(Span (Pos l c) _), card = Nothing})) = "Line " ++ show l ++ " column " ++ show c ++ "\n" - isEmptyCard (IRClafer (IClafer{cinPos=(PosSpan _ (Pos l c) _), card = Nothing})) = "Line " ++ show l ++ " column " ++ show c ++ "\n" + isEmptyCard (IRClafer (IClafer{_cinPos=(Span (Pos l c) _), _card = Nothing})) = "Line " ++ show l ++ " column " ++ show c ++ "\n" + isEmptyCard (IRClafer (IClafer{_cinPos=(PosSpan _ (Pos l c) _), _card = Nothing})) = "Line " ++ show l ++ " column " ++ show c ++ "\n" isEmptyCard _ = "" case_stringEqual :: Assertion diff --git a/test/Suite/SimpleScopeAnalyser.hs b/test/Suite/SimpleScopeAnalyser.hs new file mode 100644 --- /dev/null +++ b/test/Suite/SimpleScopeAnalyser.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE TemplateHaskell #-} +{- + Copyright (C) 2013 Luke Brown + + Permission is hereby granted, free of charge, to any person obtaining a copy of + this software and associated documentation files (the "Software"), to deal in + the Software without restriction, including without limitation the rights to + use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies + of the Software, and to permit persons to whom the Software is furnished to do + so, subject to the following conditions: + + The above copyright notice and this permission notice shall be included in all + copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + SOFTWARE. +-} +module Suite.SimpleScopeAnalyser (tg_Test_Suite_SimpleScopeAnalyser) where + +import Language.Clafer +import Language.Clafer.Intermediate.Intclafer +import Language.Clafer.Intermediate.SimpleScopeAnalyzer +import Language.Clafer.JSONMetaData +import Language.Clafer.QNameUID +import Functions + +import qualified Data.Map as M + +import qualified Test.Framework as T +import Test.Framework.TH +import Test.Framework.Providers.HUnit +import Test.HUnit + + +tg_Test_Suite_SimpleScopeAnalyser :: T.Test +tg_Test_Suite_SimpleScopeAnalyser = $(testGroupGenerator) + +model :: String +model = unlines + [ "a 0..0" + , "b ?" + , "c" + , "d *" + , "e +" + , "f 2..4" + , "g 3..*" + , "gs -> g 2" + , "abstract H" + , " i ?" + , " j *" + , " k 2" + , "Hs -> H 3..*" + , "H1 : H 2" + , " H12 : H 2" + , "H2 : H 4..4" + , "H3 : H 1..2" + , "H4 : H 5..*" + , "Hs2 -> H 0..*" + , "Hs3 -> H 5..8" + , " l ?" + , "abstract F : H" + , "f1 : F 2..5" + , " m 0" + ] + +expectedScopesSet :: M.Map UID Integer +expectedScopesSet = M.fromList $ [ ("c0_a", 0) + -- , ("c0_b", 1) -- uses global scope + -- , ("c0_c", 1) -- uses global scope + -- , ("c0_d", 1) -- uses global scope + -- , ("c0_e", 1) -- uses global scope + , ("c0_f", 4) + , ("c0_g", 3) + , ("c0_gs", 2) + , ("c0_H", 22) + , ("c0_i", 22) + , ("c0_j", 22) + , ("c0_k", 44) + , ("c0_Hs", 16) -- not sure where the 16 comes from + , ("c0_H1", 2) + , ("c0_H12", 4) + , ("c0_H2", 4) + , ("c0_H3", 2) + , ("c0_H4", 5) + , ("c0_Hs2", 16) -- not sure where the 16 comes from + , ("c0_Hs3", 8) + , ("c0_l", 8) + , ("c0_F", 5) + , ("c0_f1", 5) + , ("c0_m", 0) + ] + + +-- aggregates a difference +aggregateDifference :: UID -> Integer -> Integer -> Maybe String +aggregateDifference k computedV expectedV = + if computedV == expectedV + then Nothing + else Just $ k ++ " | computed: " ++ show computedV ++ " | expected: " ++ show expectedV ++ " |" + +-- prints only computed scopes missing in expected +onlyComputed :: M.Map UID Integer -> M.Map UID String +onlyComputed = M.mapWithKey (\k v -> k ++ " | computed: " ++ show v ++ " | no expected |") + + +-- prints only expected scopes missing in computed +onlyExpected :: M.Map UID Integer -> M.Map UID String +onlyExpected = M.mapWithKey (\k v -> k ++ " | no computed | expected: " ++ show v ++ " |") + +case_ScopeTest :: Assertion +case_ScopeTest = do + let + -- use simple scope inference + (Right compilerResultMap) = compileOneFragment defaultClaferArgs model + (Just compilerResult) = M.lookup Alloy compilerResultMap + computedScopesSet :: M.Map UID Integer + computedScopesSet = M.fromList $ scopesList compilerResult + + differences = M.mergeWithKey aggregateDifference onlyComputed onlyExpected computedScopesSet expectedScopesSet + + (M.size differences) == 0 @? + "Computed scopes different from expected:\n" ++ (unlines $ M.foldl (\acc v -> v:acc) [] differences) + + +case_ReadScopesJSON :: Assertion +case_ReadScopesJSON = do + let + -- use simple scope inference + (Right compilerResultMap) = compileOneFragment defaultClaferArgs model + (Just compilerResult) = M.lookup Alloy compilerResultMap + Just (iModule, _, _) = cIr $ claferEnv compilerResult + + qNameMaps = deriveQNameMaps iModule + + computedScopes :: [ (UID, Integer) ] + computedScopes = scopesList compilerResult + + scopesInJSON = generateJSONScopes qNameMaps computedScopes + decodedScopes = parseJSONScopes qNameMaps scopesInJSON + + differences = M.mergeWithKey aggregateDifference onlyComputed onlyExpected (M.fromList computedScopes) (M.fromList decodedScopes) + + (M.size differences) == 0 @? + "Parsed scopes different from original:\n" ++ (unlines $ M.foldl (\acc v -> v:acc) [] differences) diff --git a/test/test-suite.hs b/test/test-suite.hs --- a/test/test-suite.hs +++ b/test/test-suite.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -XTemplateHaskell #-} +{-# LANGUAGE TemplateHaskell, DeriveDataTypeable #-} {- Copyright (C) 2013 Luke Brown @@ -20,14 +20,20 @@ OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -} +import Control.Lens +import Data.Data +import Data.Data.Lens +import Data.Typeable import Data.List import qualified Data.Map as Map import Data.Maybe import Language.Clafer import Language.Clafer.QNameUID +import Language.Clafer.Intermediate.Intclafer import Suite.Positive import Suite.Negative +import Suite.SimpleScopeAnalyser import Functions import Test.HUnit import Test.Framework @@ -35,7 +41,7 @@ import Test.Framework.Providers.HUnit tg_Main_Test_Suite = $(testGroupGenerator) -main = defaultMain[tg_Main_Test_Suite, tg_Test_Suite_Positive, tg_Test_Suite_Negative] +main = defaultMain[tg_Main_Test_Suite, tg_Test_Suite_Positive, tg_Test_Suite_Negative, tg_Test_Suite_SimpleScopeAnalyser] {- a // ::a -> c0_a @@ -55,23 +61,33 @@ a\n b\nb\nc\n d\n b\nd\n b -} +model = "a\n b\nb\nc\n d\n b\nd\n b" + case_FQMapLookup :: Assertion case_FQMapLookup = do let - (Just (iModule, _, _)) = cIr $ claferEnv $ fromJust $ Map.lookup Alloy $ fromRight $ compileOneFragment defaultClaferArgs "a\n b\nb\nc\n d\n b\nd\n b" + (Just (iModule, _, _)) = cIr $ claferEnv $ fromJust $ Map.lookup Alloy $ fromRight $ compileOneFragment defaultClaferArgs model qNameMaps = deriveQNameMaps iModule - [ "c0_a" ] == (getUIDs qNameMaps "::a" ) @? "UID for `::a` different from `c0_a`" - [ "c0_b" ] == (getUIDs qNameMaps "::a::b" ) @? "UID for `::a::b` different from `c0_b`" - [ "c1_b" ] == (getUIDs qNameMaps "::b" ) @? "UID for `::b` different from `c1_b`" - [ "c0_c" ] == (getUIDs qNameMaps "::c" ) @? "UID for `::c` different from `c0_c`" - [ "c0_d" ] == (getUIDs qNameMaps "::c::d" ) @? "UID for `::c::d` different from `c0_d`" - [ "c0_d" ] == (getUIDs qNameMaps "c::d" ) @? "UID for `c::d` different from `c0_d`" - [ "c2_b" ] == (getUIDs qNameMaps "::c::d::b" ) @? "UID for `::c::d::b` different from `c2_b`" - [ "c1_d" ] == (getUIDs qNameMaps "::d" ) @? "UID for `::d` different from `c1_d`" - [ "c3_b" ] == (getUIDs qNameMaps "::d::b" ) @? "UID for `::d::b` different from `c3_d`" + [ "c0_a" ] == getUIDs qNameMaps "::a" @? "UID for `::a` different from `c0_a`" + [ "c0_b" ] == getUIDs qNameMaps "::a::b" @? "UID for `::a::b` different from `c0_b`" + [ "c1_b" ] == getUIDs qNameMaps "::b" @? "UID for `::b` different from `c1_b`" + [ "c0_c" ] == getUIDs qNameMaps "::c" @? "UID for `::c` different from `c0_c`" + [ "c0_d" ] == getUIDs qNameMaps "::c::d" @? "UID for `::c::d` different from `c0_d`" + [ "c0_d" ] == getUIDs qNameMaps "c::d" @? "UID for `c::d` different from `c0_d`" + [ "c2_b" ] == getUIDs qNameMaps "::c::d::b" @? "UID for `::c::d::b` different from `c2_b`" + [ "c1_d" ] == getUIDs qNameMaps "::d" @? "UID for `::d` different from `c1_d`" + [ "c3_b" ] == getUIDs qNameMaps "::d::b" @? "UID for `::d::b` different from `c3_d`" null ([ "c0_b", "c1_b", "c2_b", "c3_b" ] \\ (getUIDs qNameMaps "b" )) @? "UIDs for `b` different from `c0_b`, `c1_b`, `c2_b`, `c3_b` " null ([ "c2_b", "c3_b" ] \\ (getUIDs qNameMaps "d::b" )) @? "UIDs for `d::b` different from `c2_b`, `c3_b` " null ([ "c0_d", "c1_d" ] \\ (getUIDs qNameMaps "d" )) @? "UIDs for `d` different from `c0_d`, `c1_d` " null (getUIDs qNameMaps "x") @? "UID for `x` different from []" null (getUIDs qNameMaps "::x") @? "UID for `::x` different from []" +case_AllClafersGenerics :: Assertion +case_AllClafersGenerics = do + let + (Just (iModule, _, _)) = cIr $ claferEnv $ fromJust $ Map.lookup Alloy $ fromRight $ compileOneFragment defaultClaferArgs model + allClafers :: [ IClafer ] + allClafers = universeOn biplate iModule + allClafersUids = map _uid allClafers + allClafersUids == [ "c0_a", "c0_b", "c1_b", "c0_c", "c0_d", "c2_b", "c1_d", "c3_b"] @? "All clafers\n" ++ show allClafersUids diff --git a/tools/Makefile b/tools/Makefile --- a/tools/Makefile +++ b/tools/Makefile @@ -1,22 +1,16 @@ -UNAME := $(shell uname | tr "A-Z" "a-z") - -ifeq ($(UNAME), darwin) - WGET_COMMAND := curl -O +WGET_COMMAND := wget +ifeq ($(OS),Windows_NT) + ifeq ($(shell which wget), which: wget: unkown command) + mingw-get install msys-wget-bin + endif else - ifeq ($(UNAME), mingw32_nt-6.1) - ifeq ($(shell which wget), which: wget: unkown command) - mingw-get install msys-wget-bin - endif + UNAME_S := $(shell uname -s) + ifeq ($(UNAME_S),Darwin) + WGET_COMMAND := curl -O endif - WGET_COMMAND := wget endif all: - - @if [[ "$(UNAME)"=="mingw32_nt-6.1" && -z "$(shell which wget)" ]] ; then \ - mingw-get install msys-wget-bin; \ - fi - @if test ! -f "alloy4.jar"; then \ echo "[WARNING] Missing alloy4.jar. Downloading..."; \ $(WGET_COMMAND) http://alloy.mit.edu/alloy/downloads/alloy4.jar; \