clafer 0.3.5.1 → 0.3.6

raw patch · 37 files changed

+953/−681 lines, 37 filesdep +aesondep +lensdep +textdep ~HaXmldep ~QuickCheckdep ~clafer

Dependencies added: aeson, lens, text

Dependency ranges changed: HaXml, QuickCheck, clafer, cmdargs, containers, data-stringmap, string-conversions, test-framework, test-framework-hunit, test-framework-quickcheck2

Files

CHANGES.md +4/−0
Makefile +12/−16
README.md +34/−23
clafer.cabal +44/−34
src/Language/Clafer.hs +14/−13
src/Language/Clafer/ClaferArgs.hs +13/−7
src/Language/Clafer/Common.hs +6/−6
src/Language/Clafer/Front/Absclafer.hs +7/−2
src/Language/Clafer/Generator/Alloy.hs +57/−54
src/Language/Clafer/Generator/Choco.hs +80/−80
src/Language/Clafer/Generator/Graph.hs +5/−5
src/Language/Clafer/Generator/Html.hs +4/−4
src/Language/Clafer/Generator/Python.hs +1/−1
src/Language/Clafer/Generator/Stats.hs +5/−5
src/Language/Clafer/Generator/Xml.hs +2/−2
src/Language/Clafer/Intermediate/Analysis.hs +9/−9
src/Language/Clafer/Intermediate/Desugarer.hs +7/−7
src/Language/Clafer/Intermediate/GLPKScopeAnalyzer.hs +44/−44
src/Language/Clafer/Intermediate/Intclafer.hs +79/−44
src/Language/Clafer/Intermediate/Resolver.hs +6/−6
src/Language/Clafer/Intermediate/ResolverInheritance.hs +42/−42
src/Language/Clafer/Intermediate/ResolverName.hs +27/−27
src/Language/Clafer/Intermediate/ResolverType.hs +63/−63
src/Language/Clafer/Intermediate/SimpleScopeAnalyzer.hs +67/−51
src/Language/Clafer/Intermediate/StringAnalyzer.hs +3/−3
src/Language/Clafer/Intermediate/Tracing.hs +2/−2
src/Language/Clafer/Intermediate/Transformer.hs +18/−16
src/Language/Clafer/JSONMetaData.hs +51/−6
src/Language/Clafer/Optimizer/Optimizer.hs +48/−68
src/Language/Clafer/QNameUID.hs +7/−8
test/Functions.hs +1/−1
test/Suite/Example.hs +1/−1
test/Suite/Negative.hs +2/−2
test/Suite/Positive.hs +3/−3
test/Suite/SimpleScopeAnalyser.hs +149/−0
test/test-suite.hs +28/−12
tools/Makefile +8/−14

CHANGES.md view

@@ -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)

Makefile view

@@ -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

README.md view

@@ -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 `<user>\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 <cabal's lib or share folder>`  (`C:\Users\<user>\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 `<source directory>/clafer`, execute
   * `cabal update`
 5. On Linux and Mac execute 
+  * `make init`
   * `make`
 6. On Windows (in MinGW), execute 
-  * `make glpk="/c/<your WinGLPK install dir>"`
+  * `make glpk=/c/<your WinGLPK install dir>`
 
 ### Installation
 
 1. On Linux and Mac execute 
   * `make install to=<target directory>` 
 2. On Windows (in MinGW), execute 
-  * `make glpk="/c/<your WinGLPK instal dir>" to=/c/<target directory>`  
-3. add the `<target directory>` to your system PATH
+  * `make glpk=/c/<your WinGLPK instal dir> to=/c/Users/<your user name>/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)

clafer.cabal view

@@ -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

src/Language/Clafer.hs view

@@ -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)

src/Language/Clafer/ClaferArgs.hs view

@@ -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 ""

src/Language/Clafer/Common.hs view

@@ -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]

src/Language/Clafer/Front/Absclafer.hs view

@@ -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)

src/Language/Clafer/Generator/Alloy.hs view

@@ -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

src/Language/Clafer/Generator/Choco.hs view

@@ -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)

src/Language/Clafer/Generator/Graph.hs view

@@ -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 []-}

src/Language/Clafer/Generator/Html.hs view

@@ -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 ""

src/Language/Clafer/Generator/Python.hs view

@@ -86,7 +86,7 @@   , "\tstack = []\n"
   , "\tmodule = Module.Module(\"\")\n"
   , "\tstack.append(module)\n"
-  , concatMap genPythonElement $ mDecls imodule
+  , concatMap genPythonElement $ _mDecls imodule
   , "\treturn module"
   ]

src/Language/Clafer/Generator/Stats.hs view

@@ -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

src/Language/Clafer/Generator/Xml.hs view

@@ -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
   , "</Module>"]

src/Language/Clafer/Intermediate/Analysis.hs view

@@ -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

src/Language/Clafer/Intermediate/Desugarer.hs view

@@ -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

src/Language/Clafer/Intermediate/GLPKScopeAnalyzer.hs view

@@ -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

src/Language/Clafer/Intermediate/Intclafer.hs view

@@ -1,3 +1,4 @@+{-# LANGUAGE TemplateHaskell, DeriveDataTypeable #-}
 {-
  Copyright (C) 2012-2014 Kacper Bak, Jimmy Liang, Luke Michael Brown <http://gsd.uwaterloo.ca>
 
@@ -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

src/Language/Clafer/Intermediate/Resolver.hs view

@@ -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

src/Language/Clafer/Intermediate/ResolverInheritance.hs view

@@ -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

src/Language/Clafer/Intermediate/ResolverName.hs view

@@ -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

src/Language/Clafer/Intermediate/ResolverType.hs view

@@ -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

src/Language/Clafer/Intermediate/SimpleScopeAnalyzer.hs view

@@ -1,5 +1,5 @@ {-
- Copyright (C) 2012-2014 Jimmy Liang, Kacper Bak <http://gsd.uwaterloo.ca>
+ Copyright (C) 2012-2014 Jimmy Liang, Kacper Bak, Michał Antkiewicz <http://gsd.uwaterloo.ca>
 
  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"

src/Language/Clafer/Intermediate/StringAnalyzer.hs view

@@ -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

src/Language/Clafer/Intermediate/Tracing.hs view

@@ -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]

src/Language/Clafer/Intermediate/Transformer.hs view

@@ -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'
+
+

src/Language/Clafer/JSONMetaData.hs view

@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-}
 {-
  Copyright (C) 2014 Michal Antkiewicz <http://gsd.uwaterloo.ca>
 
@@ -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

src/Language/Clafer/Optimizer/Optimizer.hs view

@@ -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

src/Language/Clafer/QNameUID.hs view

@@ -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 =

test/Functions.hs view

@@ -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

test/Suite/Example.hs view

@@ -1,4 +1,4 @@-{-# OPTIONS_GHC -XTemplateHaskell #-}
+{-# LANGUAGE TemplateHaskell #-}
 {-
  Copyright (C) 2013 Luke Brown <http://gsd.uwaterloo.ca>

test/Suite/Negative.hs view

@@ -1,4 +1,4 @@-{-# OPTIONS_GHC -XTemplateHaskell #-}
+{-# LANGUAGE TemplateHaskell #-}
 {-
  Copyright (C) 2013 Luke Brown <http://gsd.uwaterloo.ca>
 
@@ -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

test/Suite/Positive.hs view

@@ -1,4 +1,4 @@-{-# OPTIONS_GHC -XTemplateHaskell #-}
+{-# LANGUAGE TemplateHaskell #-}
 {-
  Copyright (C) 2013 Luke Brown <http://gsd.uwaterloo.ca>
 
@@ -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

+ test/Suite/SimpleScopeAnalyser.hs view

@@ -0,0 +1,149 @@+{-# LANGUAGE TemplateHaskell #-}
+{-
+ Copyright (C) 2013 Luke Brown <http://gsd.uwaterloo.ca>
+
+ 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)

test/test-suite.hs view

@@ -1,4 +1,4 @@-{-# OPTIONS_GHC -XTemplateHaskell #-}
+{-# LANGUAGE TemplateHaskell, DeriveDataTypeable #-}
 {-
  Copyright (C) 2013 Luke Brown <http://gsd.uwaterloo.ca>
 
@@ -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

tools/Makefile view

@@ -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; \