Start with repository and dependency resolution

1 files changed, 138 insertions, 47 deletions

diff --git a/CLPM/Package.icl b/CLPM/Package.icl
index 2eee207..3f3001f 100644
--- a/CLPM/Package.icl
+++ b/CLPM/Package.icl
@@ -1,9 +1,14 @@
 implementation module CLPM.Package
 
 import _SystemArray
+import StdBool
 import StdFile
-from StdFunc import o
+from StdFunc import flip, o
 import StdList
+import StdOverloaded
+import StdTuple
+
+import GenEq
 
 import Control.Applicative
 import Control.Monad
@@ -11,6 +16,7 @@ import Control.Monad
 import Data.Error
 from Data.Func import $
 import Data.Functor
+import Data.List
 import Data.Tuple
 
 import System.File
@@ -20,11 +26,69 @@ from Text import class Text(indexOf,subString),
 	instance Text String, instance + String
 import Text.JSON
 
+import CLPM.Repository
+import CLPM.Util
+
 derive JSONEncode StoredPackage, StoredOptions
 derive JSONDecode StoredPackage, StoredOptions
 
+instance <<< Package
+where
+	(<<<) f p = f <<< (jsonPrettyPrint $ toJSON $ toStoredPackage p)
+
+instance toString Version
+where toString (a,b,c) = toString a + "." + toString b + "." + toString c
+
+instance toString VersionRequirement
+where
+	toString (AtLeast v)       = ">=" + toString v
+	toString (AtMost  v)       = "<=" + toString v
+	toString (Satisfy (a,b,c)) = "~" + pt a + "." + pt b + "." + pt c
+		where pt Nothing = "?"; pt (Just i) = toString i
+	toString (Compound r1 r2)  = toString r1 + ";" + toString r2
+
+derive gEq Dependency, VersionRequirement, GitTag
+instance == Dependency where (==) a b = gEq{|*|} a b
+instance == VersionRequirement where (==) a b = gEq{|*|} a b
+instance == GitTag where (==) a b = gEq{|*|} a b
+
+instance Parse Dependency
+where
+	Parse cs
+	| not (isMember ':' cs) = Error "Dependency should contain a ':'."
+	| isEmpty vr = Error $ "No VersionRequirement for " + toString p + "."
+	| otherwise  = Parse vr >>= Ok o Package (toString p)
+	where
+		(p,[_:vr]) = span ((<>) ':') cs
+
+instance Parse VersionRequirement
+where
+	Parse [] = Error "Unexpected end of VersionRequirement."
+	Parse cs
+	| isMember ';' cs = Parse h >>= \h` -> Parse t >>= Ok o Compound h`
+		with (h,t) = span ((==) ';') cs
+	Parse ['~':cs]
+	| isEmpty r1 || isEmpty rev
+		= Error "Unexpected end of Satisfy."
+	| otherwise
+		= p maj >>= \ma ->
+			p min >>= \mi ->
+			p rev >>= \re ->
+			Ok $ Satisfy (ma,mi,re)
+	where
+		(maj,[_:r1])  = span ((<>) '.') cs
+		(min,[_:rev]) = span ((<>) '.') r1
+
+		p :: [Char] -> MaybeErrorString (Maybe Int)
+		p ['?'] = Ok Nothing
+		p cs
+		| all isDigit cs = Ok $ Just $ toInt $ toString cs
+		| otherwise = Error "Unexpected character in Satisfy."
+	Parse [c:_] = Error $ "Unexpected character '" + {c} + "' in VersionRequirement."
+
 :: StoredPackage
 	= { name    :: Maybe PackageName
+	  , version :: Maybe Version
 	  , desc    :: Maybe Description
 	  , author  :: Maybe Author
 	  , url     :: Maybe Url
@@ -34,8 +98,7 @@ derive JSONDecode StoredPackage, StoredOptions
 	  , options :: Maybe StoredOptions
 	  }
 
-:: StoredDependency :== (PackageName, StoredPackageSource)
-:: StoredPackageSource :== String
+:: StoredDependency :== String
 
 :: StoredOptions
 	= { show_result       :: Maybe Bool
@@ -46,25 +109,35 @@ derive JSONDecode StoredPackage, StoredOptions
 	  , extra_flags       :: Maybe [String]
 	  }
 
-toPackage :: StoredPackage -> Package
-toPackage spkg
-	= { Package
-	  | name    = fromJust $ spkg.StoredPackage.name <|> Just DEFAULT_NAME
-	  , desc    = fromJust $ spkg.StoredPackage.desc <|> Just DEFAULT_DESC
-	  , author  = fromJust $ spkg.StoredPackage.author <|> Just DEFAULT_AUTHOR
-	  , url     = fromJust $ spkg.StoredPackage.url <|> Just DEFAULT_URL
-	  , main    = fromJust $ spkg.StoredPackage.main <|> Just DEFAULT_MAIN
-	  , depends = map toDep $ fromJust $ spkg.StoredPackage.depends <|> Just []
-	  , paths   = fromJust $ spkg.StoredPackage.paths <|> Just DEFAULT_PATHS
-	  , options = toOptions spkg.StoredPackage.options
-	  }
+depName :: Dependency -> PackageName
+depName (Package n _) = n
+// TODO
+
+satisfies :: VersionRequirement Version -> Bool
+satisfies (AtLeast r)       v       = r <= v
+satisfies (AtMost r)        v       = r >= v
+satisfies (Satisfy (a,b,c)) (d,e,f)
+	| isJust a && d <> fromJust a = False
+	| isJust b && e <> fromJust b = False
+	| isJust c && f <> fromJust c = False
+	| otherwise                   = True
+satisfies (Compound r1 r2)  v       = satisfies r1 v && satisfies r2 v
+
+toPackage :: StoredPackage -> MaybeErrorString Package
+toPackage spkg = sequence (map parse depends`) >>= \ds -> Ok
+	{ Package
+	| name    = fromJust $ spkg.StoredPackage.name <|> Just DEFAULT_NAME
+	, version = fromJust $ spkg.StoredPackage.version <|> Just DEFAULT_VERSION
+	, desc    = fromJust $ spkg.StoredPackage.desc <|> Just DEFAULT_DESC
+	, author  = fromJust $ spkg.StoredPackage.author <|> Just DEFAULT_AUTHOR
+	, url     = fromJust $ spkg.StoredPackage.url <|> Just DEFAULT_URL
+	, main    = fromJust $ spkg.StoredPackage.main <|> Just DEFAULT_MAIN
+	, depends = ds
+	, paths   = fromJust $ spkg.StoredPackage.paths <|> Just DEFAULT_PATHS
+	, options = toOptions spkg.StoredPackage.options
+	}
 where
-	toDep :: StoredDependency -> Dependency
-	toDep (name, src)
-		= { dep_name = name, dep_source = toPackSource src }
-
-	toPackSource :: StoredPackageSource -> PackageSource
-	toPackSource sps = Git sps Latest
+	depends` = fromJust $ spkg.StoredPackage.depends <|> Just []
 
 	toOptions :: (Maybe StoredOptions) -> Options
 	toOptions Nothing = DEFAULT_OPTIONS
@@ -91,27 +164,25 @@ where
 		}
 
 toStoredPackage :: Package -> StoredPackage
-toStoredPackage pkg
-	= { StoredPackage
-	  | name    = Just pkg.Package.name
-	  , desc    = Just pkg.Package.desc
-	  , author  = Just pkg.Package.author
-	  , url     = Just pkg.Package.url
-	  , main    = Just pkg.Package.main
-	  , depends = listToMaybeList $ map toStoredDep pkg.Package.depends
-	  , paths   = listToMaybeList pkg.Package.paths
-	  , options = Just $ toStoredOpts pkg.Package.options
-	  }
+toStoredPackage pkg =
+	{ StoredPackage
+	| name    = Just pkg.Package.name
+	, version = Just pkg.Package.version
+	, desc    = Just pkg.Package.desc
+	, author  = Just pkg.Package.author
+	, url     = Just pkg.Package.url
+	, main    = Just pkg.Package.main
+	, depends = listToMaybeList $ map toStoredDep pkg.Package.depends
+	, paths   = listToMaybeList pkg.Package.paths
+	, options = Just $ toStoredOpts pkg.Package.options
+	}
 where
 	listToMaybeList :: [a] -> Maybe [a]
 	listToMaybeList [] = Nothing
 	listToMaybeList xs = Just xs
 
 	toStoredDep :: Dependency -> StoredDependency
-	toStoredDep d = (d.dep_name, toStoredPackSource d.dep_source)
-
-	toStoredPackSource :: PackageSource -> StoredPackageSource
-	toStoredPackSource (Git url t) = url
+	toStoredDep (Package d _) = d
 	// TODO
 
 	toStoredOpts :: Options -> StoredOptions
@@ -125,13 +196,33 @@ where
 		, extra_flags       = listToMaybeList opts.Options.extra_flags
 		}
 
-instance <<< Package
-where
-	(<<<) f p = f <<< (jsonPrettyPrint $ toJSON $ toStoredPackage p)
+readPackage :: String *World -> *(MaybeErrorString Package, *World)
+readPackage f w
+# (f`,w) = readFile f w
+| isError f` = (Error $ flip (+) (" " + f + ".") $ toString $ fromError f`, w)
+# pkg = fromJSON $ fromString $ fromOk f`
+| isNothing pkg = (Error "Failed to parse JSON.", w)
+= (toPackage $ fromJust pkg, w)
 
-readPackage :: String -> *World -> *(Maybe Package, *World)
-readPackage f = appFst parse o readFile f
-where parse = join o fmap (fmap toPackage o fromJSON o fromString) o error2mb
+resolveDependencies :: Repository Package -> MaybeErrorString [(Dependency, Version)]
+resolveDependencies rep pkg = res [] pkg.Package.depends
+where
+	res :: [(Dependency, Version)] [Dependency] -> MaybeErrorString [(Dependency, Version)]
+	res chosen [] = Ok chosen
+	res chosen [d=:(Package p req):ds]
+	| isNothing chosen` = case
+			[res [(d,riv.RepositoryItemVersion.version):chosen] ds \\ riv <- resolve p req rep] of
+		[] = Error $ "No suitable version for " + p + ":" + toString req + "."
+		os = if (all isError os) (hd os) (hd $ filter isOk os)
+	# (Just chosen`) = chosen`
+	| satisfies req chosen`
+		= res chosen ds
+	| otherwise
+		= Error $ "Conflict for " + p + ": " +
+			toString req + " is needed, but " +
+			toString chosen` + " is to be installed."
+	where
+		chosen` = lookup d chosen
 
 getRecursivePaths :: Package *World -> (MaybeErrorString [Path], *World)
 getRecursivePaths pkg w = getPaths` pkg.Package.paths [] pkg.Package.depends w
@@ -140,12 +231,12 @@ where
 		-> (MaybeErrorString [Path], *World)
 	getPaths` ps _   []     w = (Ok ps, w)
 	getPaths` ps pks [d:ds] w
-	| isMember d.dep_name [p.Package.name \\ p <- pks]
+	| isMember (depName d) [p.Package.name \\ p <- pks]
 		= getPaths` ps pks ds w
-	# (pkg,w) = readPackage (MODULE_DIR </> d.dep_name </> PACKAGE_FILE) w
-	| isNothing pkg
-		= (Error $ "Could not read " + PACKAGE_FILE + " for " + d.dep_name + ".",w)
-	# pkg = fromJust pkg
+	# (pkg,w) = readPackage (MODULE_DIR </> (depName d) </> PACKAGE_FILE) w
+	| isError pkg
+		= (Error $ fromError pkg, w)
+	# pkg = fromOk pkg
 	= getPaths` (removeDup $ ps ++ pkg.Package.paths) [pkg:pks] ds w
 
 optionsToFlags :: Options -> [String]