module HaskellCI.ShVersionRange (
    compilerVersionPredicate,
    compilerVersionArithPredicate,
    ) where

import HaskellCI.Prelude

import Algebra.Lattice (joins)
import Algebra.Heyting.Free (Free (..))

import qualified Algebra.Heyting.Free as F
import qualified Data.Set             as S
import qualified Distribution.Version as C

import HaskellCI.Compiler

-- $setup
-- >>> import Distribution.Pretty (prettyShow)

compilerVersionPredicate :: Set CompilerVersion -> CompilerRange -> String
compilerVersionPredicate :: Set CompilerVersion -> CompilerRange -> String
compilerVersionPredicate = (Free String -> String)
-> Set CompilerVersion -> CompilerRange -> String
compilerVersionPredicateImpl (String -> String
toTest (String -> String)
-> (Free String -> String) -> Free String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Free String -> String
freeToArith) where
    toTest :: String -> String
toTest String
expr = String
"[ " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
expr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -ne 0 ]"

compilerVersionArithPredicate :: Set CompilerVersion -> CompilerRange -> String
compilerVersionArithPredicate :: Set CompilerVersion -> CompilerRange -> String
compilerVersionArithPredicate = (Free String -> String)
-> Set CompilerVersion -> CompilerRange -> String
compilerVersionPredicateImpl Free String -> String
freeToArith

compilerVersionPredicateImpl
    :: (Free String -> String)
    -> Set CompilerVersion -> CompilerRange -> String
compilerVersionPredicateImpl :: (Free String -> String)
-> Set CompilerVersion -> CompilerRange -> String
compilerVersionPredicateImpl Free String -> String
conv Set CompilerVersion
cvs CompilerRange
cr
    | Set Version -> Bool
forall a. Set a -> Bool
S.null Set Version
ghcjsS = Free String -> String
conv Free String
ghcFree
    | Bool
otherwise     = Free String -> String
conv (Free String -> String) -> Free String -> String
forall a b. (a -> b) -> a -> b
$
        (String -> Free String
forall a. a -> Free a
Var String
"GHCJSARITH" Free String -> Free String -> Free String
forall a. Lattice a => a -> a -> a
/\ Free String
ghcjsFree) Free String -> Free String -> Free String
forall a. Lattice a => a -> a -> a
\/ (String -> Free String
forall a. a -> Free a
Var String
"! GHCJSARITH" Free String -> Free String -> Free String
forall a. Lattice a => a -> a -> a
/\ Free String
ghcFree)
  where
    R Bool
hdS Set Version
ghcS Set Version
ghcjsS = Set CompilerVersion -> R (Set Version)
partitionCompilerVersions Set CompilerVersion
cvs
    R Bool
hdR VersionRange
ghcR VersionRange
ghcjsR = CompilerRange -> R VersionRange
simplifyCompilerRange CompilerRange
cr

    -- GHCJS

    ghcjsS' :: Set Version
ghcjsS' = (Version -> Bool) -> Set Version -> Set Version
forall a. (a -> Bool) -> Set a -> Set a
S.filter (Version -> VersionRange -> Bool
`C.withinRange` VersionRange
ghcjsR) Set Version
ghcjsS

    ghcjsFree :: Free String
    ghcjsFree :: Free String
ghcjsFree = VersionRange -> Free String
ghcVersionPredicate VersionRange
ghcjsRange

    ghcjsRange :: VersionRange
ghcjsRange = case Set Version -> [Version]
forall a. Set a -> [a]
S.toList Set Version
ghcjsS' of
        []  -> VersionRange
C.noVersion
        [Version
_] -> VersionRange
C.anyVersion
        [Version]
_   -> String -> VersionRange
forall a. HasCallStack => String -> a
error String
"multiple GHCJS versions unsupported"

    -- GHC + GHC HEAD

    ghcFree :: Free String
    ghcFree :: Free String
ghcFree = VersionRange -> Free String
ghcVersionPredicate (VersionRange
ghcHeadRange VersionRange -> VersionRange -> VersionRange
forall a. Lattice a => a -> a -> a
\/ VersionRange
ghcRange)

    -- GHC

    ghcD :: Set Version
ghcD = Set Version -> Set Version
roundDown Set Version
ghcS
    ghcS' :: Set Version
ghcS' = (Version -> Bool) -> Set Version -> Set Version
forall a. (a -> Bool) -> Set a -> Set a
S.filter (Version -> VersionRange -> Bool
`C.withinRange` VersionRange
ghcR) Set Version
ghcS

    isMinGHC :: Version -> Bool
isMinGHC Version
u = Version -> Maybe Version
forall a. a -> Maybe a
Just Version
u Maybe Version -> Maybe Version -> Bool
forall a. Eq a => a -> a -> Bool
== ((Version, Set Version) -> Version)
-> Maybe (Version, Set Version) -> Maybe Version
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Version, Set Version) -> Version
forall a b. (a, b) -> a
fst (Set Version -> Maybe (Version, Set Version)
forall a. Set a -> Maybe (a, Set a)
S.minView Set Version
ghcD)

    -- if we build with GHC HEAD, than none of known versions is maxGHC.
    isMaxGHC :: Version -> Bool
isMaxGHC Version
u | Bool
hdS       = Bool
False
               | Bool
otherwise = Version -> Maybe Version
forall a. a -> Maybe a
Just Version
u Maybe Version -> Maybe Version -> Bool
forall a. Eq a => a -> a -> Bool
== ((Version, Set Version) -> Version)
-> Maybe (Version, Set Version) -> Maybe Version
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Version, Set Version) -> Version
forall a b. (a, b) -> a
fst (Set Version -> Maybe (Version, Set Version)
forall a. Set a -> Maybe (a, Set a)
S.maxView Set Version
ghcD)

    findGhc :: Version -> VersionRange
    findGhc :: Version -> VersionRange
findGhc Version
v = case (Version -> Set Version -> Maybe Version
forall a. Ord a => a -> Set a -> Maybe a
S.lookupLE Version
v Set Version
ghcD, Version -> Set Version -> Maybe Version
forall a. Ord a => a -> Set a -> Maybe a
S.lookupGT Version
v Set Version
ghcD) of
        (Maybe Version
Nothing, Maybe Version
_)      -> VersionRange
C.noVersion
        (Just Version
u, Maybe Version
Nothing) -> Version -> VersionRange
orLater Version
u
        (Just Version
u, Just Version
w)  -> Version -> VersionRange
orLater Version
u VersionRange -> VersionRange -> VersionRange
forall a. Lattice a => a -> a -> a
/\ Version -> VersionRange
earlier Version
w
      where
        orLater :: Version -> VersionRange
orLater Version
u | Version -> Bool
isMinGHC Version
u = VersionRange
C.anyVersion
                  | Bool
otherwise  = Version -> VersionRange
C.orLaterVersion Version
u

        earlier :: Version -> VersionRange
earlier Version
u | Version -> Bool
isMaxGHC Version
u = VersionRange
C.anyVersion
                  | Bool
otherwise  = Version -> VersionRange
C.earlierVersion Version
u


    ghcRange :: VersionRange
    ghcRange :: VersionRange
ghcRange = (VersionRange -> VersionRange -> VersionRange)
-> VersionRange -> [VersionRange] -> VersionRange
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr VersionRange -> VersionRange -> VersionRange
forall a. Lattice a => a -> a -> a
(\/) VersionRange
C.noVersion ([VersionRange] -> VersionRange) -> [VersionRange] -> VersionRange
forall a b. (a -> b) -> a -> b
$ (Version -> VersionRange) -> [Version] -> [VersionRange]
forall a b. (a -> b) -> [a] -> [b]
map Version -> VersionRange
findGhc ([Version] -> [VersionRange]) -> [Version] -> [VersionRange]
forall a b. (a -> b) -> a -> b
$ Set Version -> [Version]
forall a. Set a -> [a]
S.toList Set Version
ghcS'

    -- GHC HEAD

    ghcHeadRange :: VersionRange
    ghcHeadRange :: VersionRange
ghcHeadRange
        | Bool
hdR Bool -> Bool -> Bool
&& Bool
hdS = Version -> VersionRange
C.laterVersion (Set Version -> Version
forall a. Set a -> a
S.findMax Set Version
ghcS)
        | Bool
otherwise  = VersionRange
C.noVersion

data R a = R Bool a a
  deriving (Int -> R a -> String -> String
[R a] -> String -> String
R a -> String
(Int -> R a -> String -> String)
-> (R a -> String) -> ([R a] -> String -> String) -> Show (R a)
forall a. Show a => Int -> R a -> String -> String
forall a. Show a => [R a] -> String -> String
forall a. Show a => R a -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: forall a. Show a => Int -> R a -> String -> String
showsPrec :: Int -> R a -> String -> String
$cshow :: forall a. Show a => R a -> String
show :: R a -> String
$cshowList :: forall a. Show a => [R a] -> String -> String
showList :: [R a] -> String -> String
Show)

partitionCompilerVersions :: Set CompilerVersion -> R (Set Version)
partitionCompilerVersions :: Set CompilerVersion -> R (Set Version)
partitionCompilerVersions = (CompilerVersion -> R (Set Version) -> R (Set Version))
-> R (Set Version) -> Set CompilerVersion -> R (Set Version)
forall a b. (a -> b -> b) -> b -> Set a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr CompilerVersion -> R (Set Version) -> R (Set Version)
f (Bool -> Set Version -> Set Version -> R (Set Version)
forall a. Bool -> a -> a -> R a
R Bool
False Set Version
forall a. Set a
S.empty Set Version
forall a. Set a
S.empty) where
    f :: CompilerVersion -> R (Set Version) -> R (Set Version)
f (GHC Version
v)   (R Bool
hd Set Version
ghc Set Version
ghcjs) = Bool -> Set Version -> Set Version -> R (Set Version)
forall a. Bool -> a -> a -> R a
R Bool
hd (Version -> Set Version -> Set Version
forall a. Ord a => a -> Set a -> Set a
S.insert Version
v Set Version
ghc) Set Version
ghcjs
    f (GHCJS Version
v) (R Bool
hd Set Version
ghc Set Version
ghcjs) = Bool -> Set Version -> Set Version -> R (Set Version)
forall a. Bool -> a -> a -> R a
R Bool
hd Set Version
ghc (Version -> Set Version -> Set Version
forall a. Ord a => a -> Set a -> Set a
S.insert Version
v Set Version
ghcjs)
    f CompilerVersion
GHCHead   (R Bool
_ Set Version
ghc Set Version
ghcjs)  = Bool -> Set Version -> Set Version -> R (Set Version)
forall a. Bool -> a -> a -> R a
R Bool
True Set Version
ghc Set Version
ghcjs

simplifyCompilerRange :: CompilerRange -> R VersionRange
simplifyCompilerRange :: CompilerRange -> R VersionRange
simplifyCompilerRange CompilerRange
RangeGHC   = Bool -> VersionRange -> VersionRange -> R VersionRange
forall a. Bool -> a -> a -> R a
R Bool
True VersionRange
C.anyVersion VersionRange
C.noVersion
simplifyCompilerRange CompilerRange
RangeGHCJS = Bool -> VersionRange -> VersionRange -> R VersionRange
forall a. Bool -> a -> a -> R a
R Bool
False VersionRange
C.noVersion VersionRange
C.anyVersion
simplifyCompilerRange (Range VersionRange
vr) = Bool -> VersionRange -> VersionRange -> R VersionRange
forall a. Bool -> a -> a -> R a
R (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ VersionRange -> Bool
C.hasUpperBound VersionRange
vr) VersionRange
vr VersionRange
vr
simplifyCompilerRange (RangeUnion CompilerRange
a CompilerRange
b) =
    case (CompilerRange -> R VersionRange
simplifyCompilerRange CompilerRange
a, CompilerRange -> R VersionRange
simplifyCompilerRange CompilerRange
b) of
        (R Bool
x VersionRange
y VersionRange
z, R Bool
u VersionRange
v VersionRange
w) -> Bool -> VersionRange -> VersionRange -> R VersionRange
forall a. Bool -> a -> a -> R a
R (Bool
x Bool -> Bool -> Bool
forall a. Lattice a => a -> a -> a
\/ Bool
u) (VersionRange
y VersionRange -> VersionRange -> VersionRange
forall a. Lattice a => a -> a -> a
\/ VersionRange
v) (VersionRange
z VersionRange -> VersionRange -> VersionRange
forall a. Lattice a => a -> a -> a
\/ VersionRange
w)
simplifyCompilerRange (RangeInter CompilerRange
a CompilerRange
b) =
    case (CompilerRange -> R VersionRange
simplifyCompilerRange CompilerRange
a, CompilerRange -> R VersionRange
simplifyCompilerRange CompilerRange
b) of
        (R Bool
x VersionRange
y VersionRange
z, R Bool
u VersionRange
v VersionRange
w) -> Bool -> VersionRange -> VersionRange -> R VersionRange
forall a. Bool -> a -> a -> R a
R (Bool
x Bool -> Bool -> Bool
forall a. Lattice a => a -> a -> a
/\ Bool
u) (VersionRange
y VersionRange -> VersionRange -> VersionRange
forall a. Lattice a => a -> a -> a
/\ VersionRange
v) (VersionRange
z VersionRange -> VersionRange -> VersionRange
forall a. Lattice a => a -> a -> a
/\ VersionRange
w)
simplifyCompilerRange (RangePoints Set CompilerVersion
vs) = (CompilerVersion -> R VersionRange -> R VersionRange)
-> R VersionRange -> Set CompilerVersion -> R VersionRange
forall a b. (a -> b -> b) -> b -> Set a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr CompilerVersion -> R VersionRange -> R VersionRange
f (Bool -> VersionRange -> VersionRange -> R VersionRange
forall a. Bool -> a -> a -> R a
R Bool
False VersionRange
C.noVersion VersionRange
C.noVersion) Set CompilerVersion
vs where
    f :: CompilerVersion -> R VersionRange -> R VersionRange
f (GHC Version
v)   (R Bool
hd VersionRange
ghc VersionRange
ghcjs) = Bool -> VersionRange -> VersionRange -> R VersionRange
forall a. Bool -> a -> a -> R a
R Bool
hd (Version -> VersionRange
C.thisVersion Version
v VersionRange -> VersionRange -> VersionRange
forall a. Lattice a => a -> a -> a
\/ VersionRange
ghc) VersionRange
ghcjs
    f (GHCJS Version
v) (R Bool
hd VersionRange
ghc VersionRange
ghcjs) = Bool -> VersionRange -> VersionRange -> R VersionRange
forall a. Bool -> a -> a -> R a
R Bool
hd VersionRange
ghc (Version -> VersionRange
C.thisVersion Version
v VersionRange -> VersionRange -> VersionRange
forall a. Lattice a => a -> a -> a
\/ VersionRange
ghcjs)
    f CompilerVersion
GHCHead   (R Bool
_  VersionRange
ghc VersionRange
ghcjs) = Bool -> VersionRange -> VersionRange -> R VersionRange
forall a. Bool -> a -> a -> R a
R Bool
True VersionRange
ghc VersionRange
ghcjs

ghcVersionPredicate :: C.VersionRange -> Free String
ghcVersionPredicate :: VersionRange -> Free String
ghcVersionPredicate VersionRange
vr
    | VersionRange -> VersionRange -> Bool
equivVersionRanges VersionRange
C.noVersion VersionRange
vr  = Free String
forall a. BoundedJoinSemiLattice a => a
bottom
    | VersionRange -> VersionRange -> Bool
equivVersionRanges VersionRange
C.anyVersion VersionRange
vr = Free String
forall a. BoundedMeetSemiLattice a => a
top
    | Bool
otherwise                          = VersionRange -> Free String
ghcVersionPredicate' VersionRange
vr

ghcVersionPredicate' :: C.VersionRange -> Free String
ghcVersionPredicate' :: VersionRange -> Free String
ghcVersionPredicate' = [VersionInterval] -> Free String
conj ([VersionInterval] -> Free String)
-> (VersionRange -> [VersionInterval])
-> VersionRange
-> Free String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VersionRange -> [VersionInterval]
C.asVersionIntervals
  where
    conj :: [VersionInterval] -> Free String
conj = [Free String] -> Free String
forall a (f :: * -> *).
(BoundedJoinSemiLattice a, Foldable f) =>
f a -> a
joins ([Free String] -> Free String)
-> ([VersionInterval] -> [Free String])
-> [VersionInterval]
-> Free String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VersionInterval -> Free String)
-> [VersionInterval] -> [Free String]
forall a b. (a -> b) -> [a] -> [b]
map VersionInterval -> Free String
disj

    disj :: C.VersionInterval -> Free String
    disj :: VersionInterval -> Free String
disj (C.VersionInterval (C.LowerBound Version
v Bound
C.InclusiveBound) (C.UpperBound Version
u Bound
C.InclusiveBound))
        | Version
v Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
== Version
u                = String -> Free String
forall a. a -> Free a
Var (String
"HCNUMVER == " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Version -> String
f Version
v)
    disj (C.VersionInterval LowerBound
lb UpperBound
C.NoUpperBound)
        | LowerBound -> Bool
isInclZero LowerBound
lb         = Free String
forall a. BoundedMeetSemiLattice a => a
top
        | Bool
otherwise             = String -> Free String
forall a. a -> Free a
Var (LowerBound -> String
lower LowerBound
lb)
    disj (C.VersionInterval LowerBound
lb (C.UpperBound Version
v Bound
b))
        | LowerBound -> Bool
isInclZero LowerBound
lb         = String -> Free String
forall a. a -> Free a
Var (Version -> Bound -> String
upper Version
v Bound
b)
        | Bool
otherwise             = String -> Free String
forall a. a -> Free a
Var (LowerBound -> String
lower LowerBound
lb) Free String -> Free String -> Free String
forall a. Lattice a => a -> a -> a
/\ String -> Free String
forall a. a -> Free a
Var (Version -> Bound -> String
upper Version
v Bound
b)

    isInclZero :: LowerBound -> Bool
isInclZero (C.LowerBound Version
v Bound
C.InclusiveBound) = Version
v Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
== [Int] -> Version
C.mkVersion [Int
0]
    isInclZero (C.LowerBound Version
_ Bound
C.ExclusiveBound) = Bool
False

    lower :: LowerBound -> String
lower (C.LowerBound Version
v Bound
C.InclusiveBound) = String
"HCNUMVER >= " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Version -> String
f Version
v
    lower (C.LowerBound Version
v Bound
C.ExclusiveBound) = String
"HCNUMVER > " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Version -> String
f Version
v

    upper :: Version -> Bound -> String
upper Version
v Bound
C.InclusiveBound = String
"HCNUMVER <= " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Version -> String
f Version
v
    upper Version
v Bound
C.ExclusiveBound = String
"HCNUMVER < " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Version -> String
f Version
v

    f :: Version -> String
f = Version -> String
ghcVersionToString

-------------------------------------------------------------------------------
-- Utilities
-------------------------------------------------------------------------------

ghcVersionToString :: C.Version -> String
ghcVersionToString :: Version -> String
ghcVersionToString Version
v =  case Version -> [Int]
C.versionNumbers Version
v of
    []        -> String
"0"
    [Int
x]       -> Int -> String
forall a. Show a => a -> String
show (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
10000)
    [Int
x,Int
y]     -> Int -> String
forall a. Show a => a -> String
show (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
10000 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
100)
    (Int
x:Int
y:Int
z:[Int]
_) -> Int -> String
forall a. Show a => a -> String
show (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
10000 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
100 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
z)

-- | Round down a first version in major series.
--
-- >>> let rd = map prettyShow . S.toList . roundDown . S.fromList . map C.mkVersion
--
-- >>> rd []
-- []
--
-- >>> rd [ [8,0,2] ]
-- ["8.0","8.0.3"]
--
-- >>> rd [ [8,0,2], [8,2,2], [8,4,4], [8,6,5], [8,8,1] ]
-- ["8.0","8.2","8.4","8.6","8.8","8.8.2"]
--
-- >>> rd [ [8,6,1], [8,6,2], [8,6,3], [8,6,4], [8,6,5] ]
-- ["8.6","8.6.2","8.6.3","8.6.4","8.6.5","8.6.6"]
--
roundDown :: Set Version -> Set Version
roundDown :: Set Version -> Set Version
roundDown = Set Version -> [Version] -> Set Version
go Set Version
forall a. Set a
S.empty ([Version] -> Set Version)
-> (Set Version -> [Version]) -> Set Version -> Set Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Version -> [Version]
forall a. Set a -> [a]
S.toList where
    go :: Set Version -> [Version] -> Set Version
go !Set Version
acc []      = Set Version
acc
    go !Set Version
acc [Version
v]
        | Version -> Set Version -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member Version
m Set Version
acc = Version -> Set Version -> Set Version
forall a. Ord a => a -> Set a -> Set a
S.insert Version
v (Set Version -> Set Version) -> Set Version -> Set Version
forall a b. (a -> b) -> a -> b
$ Version -> Set Version -> Set Version
forall a. Ord a => a -> Set a -> Set a
S.insert (Version -> Version
up Version
v) Set Version
acc
        | Bool
otherwise      = Version -> Set Version -> Set Version
forall a. Ord a => a -> Set a -> Set a
S.insert Version
m (Set Version -> Set Version) -> Set Version -> Set Version
forall a b. (a -> b) -> a -> b
$ Version -> Set Version -> Set Version
forall a. Ord a => a -> Set a -> Set a
S.insert (Version -> Version
up Version
v) Set Version
acc
      where
        m :: Version
m = let (Int
x,Int
y) = Version -> (Int, Int)
ghcMajVer Version
v in [Int] -> Version
C.mkVersion [Int
x,Int
y]
    go !Set Version
acc (Version
v:[Version]
vs)
        | Version -> Set Version -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member Version
m Set Version
acc = Set Version -> [Version] -> Set Version
go (Version -> Set Version -> Set Version
forall a. Ord a => a -> Set a -> Set a
S.insert Version
v Set Version
acc) [Version]
vs
        | Bool
otherwise      = Set Version -> [Version] -> Set Version
go (Version -> Set Version -> Set Version
forall a. Ord a => a -> Set a -> Set a
S.insert Version
m Set Version
acc) [Version]
vs
      where
        m :: Version
m = let (Int
x,Int
y) = Version -> (Int, Int)
ghcMajVer Version
v in [Int] -> Version
C.mkVersion [Int
x,Int
y]

    up :: Version -> Version
up Version
v = [Int] -> Version
C.mkVersion ([Int] -> Version) -> [Int] -> Version
forall a b. (a -> b) -> a -> b
$ case Version -> [Int]
C.versionNumbers Version
v of
        []     -> [Int
1]
        (Int
x:[Int]
xs) -> Int -> [Int] -> [Int]
forall {t}. Num t => t -> [t] -> [t]
up' Int
x [Int]
xs

    up' :: t -> [t] -> [t]
up' t
x []     = [t
x t -> t -> t
forall a. Num a => a -> a -> a
+ t
1]
    up' t
x (t
y:[t]
ys) = t
x t -> [t] -> [t]
forall a. a -> [a] -> [a]
: t -> [t] -> [t]
up' t
y [t]
ys

-------------------------------------------------------------------------------
-- Arithmetic expression
-------------------------------------------------------------------------------

freeToArith :: Free String -> String
freeToArith :: Free String -> String
freeToArith Free String
z
    | Free String
z Free String -> Free String -> Bool
forall a. Eq a => a -> a -> Bool
== Free String
forall a. BoundedMeetSemiLattice a => a
top    = String
"1"
    | Free String
z Free String -> Free String -> Bool
forall a. Eq a => a -> a -> Bool
== Free String
forall a. BoundedJoinSemiLattice a => a
bottom = String
"0"
    | Bool
otherwise   = String
"$((" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Free String -> String
go Int
0 Free String
z String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"))"
  where
    go :: Int -> Free String -> String
    go :: Int -> Free String -> String
go Int
_ (Var String
x)  = String
x
    go Int
_ Free String
F.Bottom = String
"1"
    go Int
_ Free String
F.Top    = String
"0"

    go Int
d (Free String
x :/\: Free String
y) = Bool -> String -> String
parens (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
3)
        (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Int -> Free String -> String
go Int
4 Free String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" && " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Free String -> String
go Int
3 Free String
y
    go Int
d (Free String
x :\/: Free String
y) = Bool -> String -> String
parens (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
2)
        (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Int -> Free String -> String
go Int
3 Free String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" || " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Free String -> String
go Int
2 Free String
y

    go Int
d (Free String
x :=>: Free String
y) = Bool -> String -> String
parens (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
2)
        (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
"! (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Free String -> String
go Int
0 Free String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") || " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Free String -> String
go Int
2 Free String
y

    parens :: Bool -> String -> String
    parens :: Bool -> String -> String
parens Bool
True  String
s = String
"{ " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"; }"
    parens Bool
False String
s = String
s

-------------------------------------------------------------------------------
-- PosNeg
-------------------------------------------------------------------------------

{-
data PosNeg a = Pos a | Neg a
  deriving (Eq, Ord, Show, Functor)

neg :: PosNeg a -> PosNeg a
neg (Pos x) = Neg x
neg (Neg x) = Pos x

instance Applicative PosNeg where
    pure  = Pos
    (<*>) = ap

instance Monad PosNeg where
    return = pure

    Pos x >>= f = f x
    Neg x >>= f = neg (f x)
-}