Merge pull request #975 from AmpersandTarski/development

Release v.3.17.1

ArchitectureAndDesign/Syntax/README.md

@@ -7,4 +7,4 @@ The above link is the syntax as it is currently in use at the course [Ontwerpen
 
 In the underlying folders you can find .ebnf files of specific versions of Ampersand. These files can be used to [generate Railroad diagrams at the site of Gunther Rademacher] (http://www.bottlecaps.de/rr/ui)
 
-Unfortunately there is currently no way to automatically keep the .ebnf files in sync with the Ampersand parser sourcecode. Therefor, the actual syntax may differ from what is mentioned in the .ebnf files.
+Unfortunately there is currently no way to automatically keep the .ebnf files in sync with the Ampersand parser sourcecode. Therefore, the actual syntax may differ from what is mentioned in the .ebnf files.

ReleaseNotes.md

@@ -1,5 +1,9 @@
 # Release notes of Ampersand
 
+## v3.17.1 (7 june 2019)
+
+* A lot of refactoring took place this release, embracing best practices from the RIO library. First phase. In the next couple of releases, we plan to gradually do more of this refactoring.
+
 ## v3.17.0 (10 may 2019)
 
 * [Issue #923](https://github.com/AmpersandTarski/Ampersand/issues/923) Lexer error message had disappeared. Now they show again.

Setup.hs

@@ -4,9 +4,9 @@ where
 import qualified Codec.Compression.GZip as GZip
 import           Control.Exception
 import qualified Data.ByteString.Lazy.Char8 as BS
-import           Data.Char
+import           RIO.Char
 import           Data.Either
-import           Data.List
+import qualified RIO.List as L
 import           Data.Time.Clock
 import qualified Data.Time.Format as DTF
 import           Data.Time.LocalTime
@@ -205,7 +205,7 @@ data FileKind = PandocTemplates | FormalAmpersand | SystemContext deriving (Show
 mkStaticFileModule :: [String] -> String
 mkStaticFileModule sfDeclStrs =
   unlines staticFileModuleHeader ++
-  "  [ " ++ intercalate "\n  , " sfDeclStrs ++ "\n" ++
+  "  [ " ++ L.intercalate "\n  , " sfDeclStrs ++ "\n" ++
   "  ]\n"
 
 staticFileModuleHeader :: [String]

app/AmpPreProc/Main.hs

@@ -3,8 +3,7 @@ module Main (main) where
 import Ampersand
 import System.Environment
 import Ampersand.Input.PreProcessor
-import Ampersand.Basics.UTF8 (readUTF8File)
-import qualified Data.Set as Set
+import qualified RIO.Set as Set
 
 main :: IO ()
 main =

app/Ampersand/Main.hs

@@ -2,8 +2,8 @@
 module Main(main) where
 
 import           Ampersand
-import           Data.List
-import qualified Data.List.NonEmpty as NEL (toList)
+import qualified RIO.List as L
+import qualified Data.List.NonEmpty as NEL
 import System.Environment    (getArgs, getProgName)
 
 main :: IO ()
@@ -16,7 +16,7 @@ main =
             ; gMulti <- createMulti opts
             ; case gMulti of
                 Errors err    -> 
-                   exitWith . NoValidFSpec . intersperse  (replicate 30 '=') 
+                   exitWith . NoValidFSpec . L.intersperse  (replicate 30 '=') 
                  . fmap show . NEL.toList $ err
                 Checked multi ws -> do
                    mapM_  putStrLn . concatMap (lines . show) $ ws

app/RegressionTest/Main.hs

@@ -3,7 +3,6 @@ module Main (main) where
 import Ampersand.Basics
 import Ampersand.Test.Regression(DirContent(..),DirData(..),process)
 import Conduit
-import Control.Monad --(filterM, forM_, foldM,when)
 import System.Directory (getDirectoryContents, doesFileExist, doesDirectoryExist, makeAbsolute)
 import System.Exit --(ExitCode, exitFailure, exitSuccess)
 import System.FilePath ((</>))
@@ -52,7 +51,8 @@ walk path = do
             isFile entry = doesFileExist (path </> entry)
             isDir entry = doesDirectoryExist (path </> entry)
             filterHidden paths = return $ filter (not.isHidden) paths
-            isHidden dir = head dir == '.'
+            isHidden ('.':_) = True
+            isHidden _       = False
 
 -- Convert a DirData into an Int that contains the number of failed tests
 myVisitor :: ConduitT DirData Int IO ()

package.yaml

@@ -1,5 +1,5 @@
 name:           ampersand
-version:        3.17.0
+version:        3.17.1
 author:         Stef Joosten
 maintainer:     [email protected]
 synopsis:       Toolsuite for automated design of enterprise information systems.
@@ -99,7 +99,6 @@ library:
       - Ampersand.Basics.PandocExtended
       - Ampersand.Basics.Prelude
       - Ampersand.Basics.String
-      - Ampersand.Basics.UTF8
       - Ampersand.Basics.Unique
       - Ampersand.Basics.Version
       - Ampersand.Classes
@@ -149,7 +148,7 @@ library:
       - Ampersand.Misc
       - Ampersand.Misc.Options
       - Ampersand.Output
-#      - Ampersand.Output.FSpec2Excel
+      - Ampersand.Output.FSpec2Excel
       - Ampersand.Output.FSpec2Pandoc
       - Ampersand.Output.FSpec2SQL
       - Ampersand.Output.PandocAux
@@ -197,6 +196,7 @@ custom-setup:
       - directory == 1.3.*
       - filepath == 1.4.*
       - process == 1.6.*
+      - rio == 0.1.*
       - time == 1.8.*
       - zlib == 0.6.*
 

src/Ampersand.hs

@@ -12,7 +12,7 @@ module Ampersand
   ) 
 where
 import Ampersand.ADL1
-import Ampersand.Basics
+import Ampersand.Basics hiding (Identity)
 import Ampersand.Classes
 import Ampersand.Components
 import Ampersand.Daemon.Daemon

src/Ampersand/ADL1/Disambiguate.hs

@@ -11,8 +11,8 @@ module Ampersand.ADL1.Disambiguate
 import           Ampersand.Basics
 import           Ampersand.Core.ParseTree
 import           Ampersand.Core.AbstractSyntaxTree
-import qualified Data.List.NonEmpty as NEL (toList,fromList)
-import qualified Data.Set as Set
+import qualified Data.List.NonEmpty as NEL
+import qualified RIO.Set as Set
 import           Control.Arrow
 import           Text.PrettyPrint.Leijen (Pretty(..),text)
 
@@ -88,10 +88,14 @@ propagateConstraints topDown bottomUp
          ,bottomUpTargetTypes = bottomUpTargetTypes topDown ++ bottomUpTargetTypes bottomUp
          }
 instance Disambiguatable P_IdentDf where
-  disambInfo (P_Id o nm c []) _ = ( P_Id o nm c [], noConstraints)
-  disambInfo (P_Id o nm c (a:lst)) _     = (P_Id o nm c (a':lst'), Cnstr (bottomUpSourceTypes aRestr++bottomUpSourceTypes nxt) [])
-       where (a', aRestr)            = disambInfo a (Cnstr [MustBe (pCpt2aCpt c)] [])
-             (P_Id _ _ _ lst', nxt)  = disambInfo (P_Id o nm c lst) (Cnstr [MustBe (pCpt2aCpt c)] [])
+--  disambInfo (P_Id o nm c []) _ = ( P_Id o nm c [], noConstraints)
+--  disambInfo (P_Id o nm c (a:lst)) _     = (P_Id o nm c (a':lst'), Cnstr (bottomUpSourceTypes aRestr++bottomUpSourceTypes nxt) [])
+--       where (a', aRestr)            = disambInfo a (Cnstr [MustBe (pCpt2aCpt c)] [])
+--             (P_Id _ _ _ lst', nxt)  = disambInfo (P_Id o nm c lst) (Cnstr [MustBe (pCpt2aCpt c)] [])
+  disambInfo (P_Id o nm c atts) _     = (P_Id o nm c atts', Cnstr (concatMap bottomUpSourceTypes . NEL.toList $ restr') [])
+     where
+      (atts', restr') = NEL.unzip $
+           fmap (\a -> disambInfo a (Cnstr [MustBe (pCpt2aCpt c)] [])) atts
 instance Disambiguatable P_IdentSegmnt where
   disambInfo (P_IdentExp v) x = (P_IdentExp v', rt)
      where (v',rt) = disambInfo v x
@@ -121,7 +125,7 @@ instance Disambiguatable P_ViewD where
                   , vd_isDefault = d
                   , vd_html = h
                   , vd_ats  = a
-                  } _ = ( P_Vd o s c d h (map (\x -> fst (disambInfo x constraints)) a)
+                  } _ = ( P_Vd o s c d h (fmap (\x -> fst (disambInfo x constraints)) a)
                         , constraints
                         )
    where constraints = Cnstr [MustBe (pCpt2aCpt c)] []

src/Ampersand/ADL1/Expression.hs

@@ -10,7 +10,8 @@ module Ampersand.ADL1.Expression (
 where
 import           Ampersand.Basics
 import           Ampersand.Core.AbstractSyntaxTree
-import qualified Data.Set as Set
+import qualified Data.List.NonEmpty as NEL
+import qualified RIO.Set as Set
 
 -- | subst is used to replace each occurrence of a relation
 --   with an expression. The parameter expr will therefore be applied to an
@@ -215,17 +216,17 @@ isFitForCrudD :: Expression -> Bool
 isFitForCrudD _ = True
 
 
-exprIsc2list, exprUni2list, exprCps2list, exprRad2list, exprPrd2list :: Expression -> [Expression]
-exprIsc2list (EIsc (l,r)) = exprIsc2list l++exprIsc2list r
-exprIsc2list r            = [r]
-exprUni2list (EUni (l,r)) = exprUni2list l++exprUni2list r
-exprUni2list r            = [r]
-exprCps2list (ECps (l,r)) = exprCps2list l++exprCps2list r
-exprCps2list r            = [r]
-exprRad2list (ERad (l,r)) = exprRad2list l++exprRad2list r
-exprRad2list r            = [r]
-exprPrd2list (EPrd (l,r)) = exprPrd2list l++exprPrd2list r
-exprPrd2list r            = [r]
+exprIsc2list, exprUni2list, exprCps2list, exprRad2list, exprPrd2list :: Expression -> NEL.NonEmpty Expression
+exprIsc2list (EIsc (l,r)) = exprIsc2list l <> exprIsc2list r
+exprIsc2list r            = r NEL.:| []
+exprUni2list (EUni (l,r)) = exprUni2list l <> exprUni2list r
+exprUni2list r            = r NEL.:| []
+exprCps2list (ECps (l,r)) = exprCps2list l <> exprCps2list r
+exprCps2list r            = r NEL.:| []
+exprRad2list (ERad (l,r)) = exprRad2list l <> exprRad2list r
+exprRad2list r            = r NEL.:| []
+exprPrd2list (EPrd (l,r)) = exprPrd2list l <> exprPrd2list r
+exprPrd2list r            = r NEL.:| []
 
 insParentheses :: Expression -> Expression
 insParentheses = insPar 0
@@ -235,22 +236,27 @@ insParentheses = insPar 0
      insPar :: Integer -> Expression -> Expression
      insPar i  (EEqu (l,r)) = wrap i 0 (insPar 1 l .==. insPar 1 r)
      insPar i  (EInc (l,r)) = wrap i 0 (insPar 1 l .|-. insPar 1 r)
-     insPar i x@EIsc{}      = wrap i 2 (foldr1 (./\.) [insPar 3 e | e<-exprIsc2list x ])
-     insPar i x@EUni{}      = wrap i 2 (foldr1 (.\/.) [insPar 3 e | e<-exprUni2list x ])
+     insPar i x@EIsc{}      = wrap i 2 (foldr1 (./\.) (fmap (insPar 3) (exprIsc2list x)))
+     insPar i x@EUni{}      = wrap i 2 (foldr1 (.\/.) (fmap (insPar 3) (exprUni2list x)))
      insPar i  (EDif (l,r)) = wrap i 4 (insPar 5 l .-. insPar 5 r)
      insPar i  (ELrs (l,r)) = wrap i 6 (insPar 7 l ./. insPar 7 r)
      insPar i  (ERrs (l,r)) = wrap i 6 (insPar 7 l .\. insPar 7 r)
      insPar i  (EDia (l,r)) = wrap i 6 (insPar 7 l .<>. insPar 7 r)
-     insPar i x@ECps{}      = wrap i 8 (foldr1 (.:.) [insPar 9 e | e<-exprCps2list x ])
-     insPar i x@ERad{}      = wrap i 8 (foldr1 (.!.) [insPar 9 e | e<-exprRad2list x ])
-     insPar i x@EPrd{}      = wrap i 8 (foldr1 (.*.) [insPar 9 e | e<-exprPrd2list x ])
+     insPar i x@ECps{}      = wrap i 8 (foldr1 (.:.) (fmap (insPar 9) (exprCps2list x)))
+     insPar i x@ERad{}      = wrap i 8 (foldr1 (.!.) (fmap (insPar 9) (exprRad2list x)))
+     insPar i x@EPrd{}      = wrap i 8 (foldr1 (.*.) (fmap (insPar 9) (exprPrd2list x)))
      insPar _  (EKl0 e)     = EKl0 (insPar 10 e)
      insPar _  (EKl1 e)     = EKl1 (insPar 10 e)
      insPar _  (EFlp e)     = EFlp (insPar 10 e)
      insPar _  (ECpl e)     = ECpl (insPar 10 e)
      insPar i  (EBrk e)     = insPar i e
-     insPar _  x            = x
-
+     insPar _ x@EDcD{}      = x  
+     insPar _ x@EDcI{}      = x  
+     insPar _ x@EEps{}      = x  
+     insPar _ x@EDcV{}      = x  
+     insPar _ x@EMp1{}      = x  
+     foldr1 :: (Expression -> Expression -> Expression) -> NEL.NonEmpty Expression -> Expression
+     foldr1 fun nonempty = foldr fun (NEL.last nonempty) (NEL.init nonempty)
 {-
    insPar 0 (r/\s/\t/\x/\y |- p)
 =

src/Ampersand/ADL1/Lattices.hs

@@ -15,12 +15,12 @@ module Ampersand.ADL1.Lattices
     , FreeLattice(..),getGroups,isInSystem
     ) where
 
-import           Ampersand.Basics
+import           Ampersand.Basics hiding (toList)
 import qualified Data.IntMap as IntMap
 import qualified Data.IntSet as IntSet
-import qualified Data.List   as Lst (partition)
+import qualified RIO.List    as L
 import qualified Data.Map    as Map
-import qualified Data.Set    as Set
+import qualified RIO.Set    as Set
 
 -- optimisations possible for the EqualitySystem(s):
 -- (1) apply optimize1 inline, that is: don't use EqualitySystem but use ES1 instead
@@ -63,6 +63,8 @@ getGroups (ES1 tran _ imap)
       overlap = IntMap.intersection allElems (IntMap.fromSet id im) -- overlap between im and the previously treated elements
       oldKeys = IntMap.elems overlap -- sets to which the overlapping items belong
       newKey = head oldKeys -- get any key name
+        where head [] = fatal "head used on empty list."
+              head (x:_) = x
       oldKeySet = IntSet.fromList oldKeys -- remove duplicates, provide efficient lookup
       -- newRev' is all items that will remain the same
       -- newItm' is all (old) items that must be renamed
@@ -97,7 +99,7 @@ findWith f f2 es@(ES1 _ back _) trmUnsimplified
             ) back
   where it = simplifySet es
         intersections [] = IntSet.empty
-        intersections x = foldr1 IntSet.intersection x
+        intersections (x:xs) = foldr IntSet.intersection x xs
         trm' = latticeToTranslatable es trm
         trm = simpl trmUnsimplified
         simpl (Meet a b)
@@ -179,13 +181,16 @@ reverseMap :: (Ord a) => [(a,[Int])] -> RevMap a
 reverseMap lst
  = RevMap (Set.fromList (map fst empties)) (buildMap rest)
  where
-   (empties,rest) = Lst.partition (null . snd) lst
+   (empties,rest) = L.partition (null . snd) lst
    buildMap [] = IntMap.empty
    buildMap o@((_,~(f:_)):_)
      = IntMap.insert f (reverseMap (map tail2 h)) (buildMap tl)
      where tail2 (a,b) = (a, tail b)
-           (h,tl) = Lst.partition ((== f) . head . snd) o
-
+           (h,tl) = L.partition ((== f) . head . snd) o
+           tail [] = fatal "tail called on empty list"
+           tail (_:t) = t
+           head [] = fatal "head used on empty list."
+           head (x:_) = x
 -- | Change the system into one with fast reverse lookups
 optimize1 :: Ord a => EqualitySystem a -> Op1EqualitySystem a
 optimize1 (ES oldmap oldimap)
@@ -218,7 +223,7 @@ addEquality' ~(ES nms imap) set1 set2
    uni' = IntSet.union set1 set2
    addRule :: IntMap.IntMap [(IntSet.IntSet, IntSet.IntSet)] -> IntSet.IntSet -> IntSet.IntSet -> IntSet.IntSet -> IntMap.IntMap [(IntSet.IntSet, IntSet.IntSet)]
    addRule oldimap origSet triggers newSet
-    = foldl updateMapForTrigger oldimap (IntSet.toList triggers)
+    = foldl' updateMapForTrigger oldimap (IntSet.toList triggers)
     where dif = IntSet.difference newSet origSet
           updateMapForTrigger :: IntMap.IntMap [(IntSet.IntSet, IntSet.IntSet)] -> Int -> IntMap.IntMap [(IntSet.IntSet, IntSet.IntSet)]
           updateMapForTrigger mp trigger
@@ -237,12 +242,12 @@ imapTranslate :: IntMap.IntMap [(IntSet.IntSet, IntSet.IntSet)] -> IntSet.IntSet
 imapTranslate imap tds doneSet
  = case IntSet.minView tds of
     Nothing -> doneSet
-    Just (todo,set) -> imapTranslate imap (newSet todo set) (IntSet.insert todo doneSet)
+    Just (todo,set') -> imapTranslate imap (newSet todo set') (IntSet.insert todo doneSet)
  where
-  newSet todo set
+  newSet todo set'
    = case IntMap.lookup todo imap of
-       Nothing -> set
-       Just lst -> IntSet.unions (set:[IntSet.difference tl doneSet | (fl,tl) <- lst, IntSet.isSubsetOf fl doneSet])
+       Nothing -> set'
+       Just lst -> IntSet.unions (set':[IntSet.difference tl doneSet | (fl,tl) <- lst, IntSet.isSubsetOf fl doneSet])
 
 -- | Data structure to capture an expression in a lattice
 data FreeLattice a