1-- 2-- Copyright 2018, Data61 3-- Commonwealth Scientific and Industrial Research Organisation (CSIRO) 4-- ABN 41 687 119 230. 5-- 6-- This software may be distributed and modified according to the terms of 7-- the GNU General Public License version 2. Note that NO WARRANTY is provided. 8-- See "LICENSE_GPLv2.txt" for details. 9-- 10-- @TAG(DATA61_GPL) 11-- 12 13-- ALSO NOTE: This module contains code borrowed from varies packages. The copyright of the borrowed 14-- code belongs to the original authors. URLs to the original source of code are included in the 15-- comments. 16-- Three majors reasons for not using the original packages: 17-- 1. modifications are necessary 18-- 2. the original package doesn't work 19-- 3. the original package is huge but we only need a tiny bit within it 20 21 22{-# LANGUAGE DataKinds #-} 23{-# LANGUAGE FlexibleContexts #-} 24{-# LANGUAGE FlexibleInstances #-} 25{-# LANGUAGE LambdaCase #-} 26{-# LANGUAGE MultiWayIf #-} 27{-# LANGUAGE PolyKinds #-} 28{-# LANGUAGE ScopedTypeVariables #-} 29{-# LANGUAGE TupleSections #-} 30{-# LANGUAGE ViewPatterns #-} 31 32module Cogent.Util where 33 34#if __GLASGOW_HASKELL__ < 709 35import Control.Applicative ((<$>)) 36import Data.Monoid 37#elif __GLASGOW_HASKELL__ < 803 38import Data.Monoid ((<>)) 39#endif 40 41import Control.Applicative (Alternative, empty) 42import Control.Arrow ((&&&)) 43import Control.Monad 44import Control.Monad.Writer 45import Control.Monad.Trans.Maybe 46import Control.Monad.Trans.Except (ExceptT(ExceptT)) 47import Data.Bifoldable 48import Data.Bifunctor 49import Data.Bitraversable 50import Data.Char 51import Data.Foldable (foldrM, toList) 52import Data.IntMap as IM (IntMap, mapKeys, delete) 53import qualified Data.Map as M 54import Data.Version (showVersion) 55import qualified Data.List as L 56import GHC.Generics (Generic) 57import System.Environment 58import System.FilePath.Posix 59import Lens.Micro 60import Lens.Micro.Mtl 61 62import Version_cogent (gitHash, configFlags) 63import Paths_cogent 64 65(<<+=) l n = l <<%= (+ n) 66 67-- 68-- functors 69 70newtype Flip f (a :: a') (b :: b') = Flip { unflip :: f b a } 71newtype Flip2 f (a :: a') (b :: b') (c :: c') = Flip2 { unflip2 :: f c b a } 72newtype Flip3 f (a :: a') (b :: b') (c :: c') (d :: d') = Flip3 { unflip3 :: f d c b a } 73newtype Flip4 f (a :: a') (b :: b') (c :: c') (d :: d') (e :: e') = Flip4 { unflip4 :: f e d c b a } 74 75flip3 :: (a -> b -> c -> d) -> c -> b -> a -> d 76flip3 f c b a = f a b c 77 78ffmap :: (Functor (Flip f a)) => (b -> b') -> f b a -> f b' a 79ffmap f = unflip . fmap f . Flip 80 81fffmap :: (Functor (Flip2 f a b)) => (c -> c') -> f c b a -> f c' b a 82fffmap f = unflip2 . fmap f . Flip2 83 84ffffmap :: (Functor (Flip3 f a b c)) => (d -> d') -> f d c b a -> f d' c b a 85ffffmap f = unflip3 . fmap f . Flip3 86 87fffffmap :: (Functor (Flip4 f a b c d)) => (e -> e') -> f e d c b a -> f e' d c b a 88fffffmap f = unflip4 . fmap f . Flip4 89 90mmapM :: (Traversable (Flip t a), Monad m) => (b -> m b') -> t b a -> m (t b' a) 91mmapM f = return . unflip <=< mapM f . Flip 92 93mmmapM :: (Traversable (Flip2 t a b), Monad m) => (c -> m c') -> t c b a -> m (t c' b a) 94mmmapM f = return . unflip2 <=< mapM f . Flip2 95 96mmmmapM :: (Traversable (Flip3 t a b c), Monad m) => (d -> m d') -> t d c b a -> m (t d' c b a) 97mmmmapM f = return . unflip3 <=< mapM f . Flip3 98 99mmmmmapM :: (Traversable (Flip4 t a b c d), Monad m) => (e -> m e') -> t e d c b a -> m (t e' d c b a) 100mmmmmapM f = return . unflip4 <=< mapM f . Flip4 101 102ttraverse :: (Traversable (Flip f b), Applicative m) => (a -> m a') -> f a b -> m (f a' b) 103ttraverse f = fmap unflip . traverse f . Flip 104 105tttraverse :: (Traversable (Flip2 f c b), Applicative m) => (a -> m a') -> f a b c -> m (f a' b c) 106tttraverse f = fmap unflip2 . traverse f . Flip2 107 108ttttraverse :: (Traversable (Flip3 f d c b), Applicative m) => (a -> m a') -> f a b c d -> m (f a' b c d) 109ttttraverse f = fmap unflip3 . traverse f . Flip3 110 111tttttraverse :: (Traversable (Flip4 f e d c b), Applicative m) => (a -> m a') -> f a b c d e -> m (f a' b c d e) 112tttttraverse f = fmap unflip4 . traverse f . Flip4 113 114ffoldMap :: (Foldable (Flip f b), Monoid m) => (a -> m) -> f a b -> m 115ffoldMap f = foldMap f . Flip 116fffoldMap f = foldMap f . Flip2 117ffffoldMap f = foldMap f . Flip3 118fffffoldMap f = foldMap f . Flip4 119 120 121-- bifunctors 122 123newtype Rotate3 f (a :: a') (b :: b') (c :: c') (d :: d') = Rotate3 { unrotate3 :: f d a b c } 124 125instance Bifunctor (Rotate3 (,,,) b c) where 126 bimap f g (Rotate3 (a,b,c,d)) = Rotate3 (g a, b, c, f d) 127instance Bifoldable (Rotate3 (,,,) b c) where 128 bifoldMap f g (Rotate3 (a,b,c,d)) = g a <> f d 129instance Bitraversable (Rotate3 (,,,) b c) where 130 bitraverse f g (Rotate3 (a,b,c,d)) = Rotate3 <$> ((,,,) <$> g a <*> pure b <*> pure c <*> f d) 131 132 133class Quadritraversable t where 134 quadritraverse :: Applicative f 135 => (a -> f a') 136 -> (b -> f b') 137 -> (c -> f c') 138 -> (d -> f d') 139 -> t a b c d 140 -> f (t a' b' c' d') 141 142class Pentatraversable t where 143 pentatraverse :: Applicative f 144 => (a -> f a') 145 -> (b -> f b') 146 -> (c -> f c') 147 -> (d -> f d') 148 -> (e -> f e') 149 -> t a b c d e 150 -> f (t a' b' c' d' e') 151 152-- 153-- name conversion 154 155cap :: String -> String -> String 156cap pre [] = error "cap" 157cap pre s@(h:t) = if not (isAlpha h) then pre ++ s 158 else toUpper h : t 159 160decap :: String -> String 161decap [] = error "decap" 162decap (h:t) = toLower h : t 163 164toIsaThyName :: String -> String 165toIsaThyName = cap "Isa" . dehyphens 166 167toHsModName = cap "Hs" . dehyphens 168toHsTypeName = cap "Hs" . dehyphens 169toHsTermName = dehyphens 170 171toCName :: String -> String 172toCName = concatMap (\c -> if c == '\'' then "_prime" else [c]) 173 174dehyphens :: String -> String 175dehyphens = map (\c -> if c == '-' then '_' else c) 176 177tupleFieldNames = map (('p':) . show) [1 :: Integer ..] 178 179-- 180-- file path 181 182-- relDir src dst pwd: calculate path from dst to src (pwd must be absolute) 183-- if src is absolute, then return absolute path of src 184-- if src is relative (from pwd), then return relative path from dst 185-- `makeRelative' doesn't behave exactly as I want 186relDir :: FilePath -> FilePath -> FilePath -> FilePath 187relDir src dst pwd 188 | isAbsolute src = dropTrailingPathSeparator src 189 | otherwise {- src is relative to pwd -} = 190 if isAbsolute dst 191 then dropTrailingPathSeparator $ pwd </> src 192 else {- src' and dst' are both relative -} 193 let src' = norm src 194 dst' = norm dst 195 pwd' = splitDirectories pwd 196 in makeRel src' dst' pwd' 197 where -- makeRelative ss ds ps: both ss and ds are normalised relative path segs, ps is absolute path segs 198 makeRel ss ds ps = let (ss',ds') = dropCommonPrefix ss ds 199 in joinPath . norm $ (inverse ds' ps) </> (joinPath ss') 200 201 -- It inherits preconditions from `makeRel' function 202 -- Postconditions: neither path is empty 203 dropCommonPrefix [] [] = (["."],["."]) 204 dropCommonPrefix [] ds = (["."],ds) 205 dropCommonPrefix ss [] = (ss,["."]) 206 dropCommonPrefix (s:ss) (d:ds) = if s == d then dropCommonPrefix ss ds else (s:ss,d:ds) 207 208 -- inverse ss ps: ss is normalised relative path segs, ps is current dir (absolute, at least ["/"]) 209 inverse ss ps = inverse' ss ps [] 210 211 inverse' [] _ is = is 212 inverse' (s:ss) ps is -- ss is not null 213 | "." <- s, [] <- ss = "." 214 | "." <- s = error "inverse: path must be norm'ed" 215 | ".." <- s = inverse' ss (init ps) $ last ps </> is 216 | otherwise = inverse' ss undefined $ ".." </> is -- no ".." should ever appear in ss thus ps is useless 217 218 -- norm: similar to System.FilePath.Posix.normalise, but also elimiate ".." as much as possible 219 norm (splitDirectories . normalise -> ss) = case ss of 220 [] -> error "norm: path cannot be empty" 221 [_] -> ss 222 ss -> let (s1,s2) = break (== "..") ss 223 in case (s1,s2) of 224 (_,[]) -> ss -- no ".." at all 225 ([],_) -> head s2 : norm (joinPath $ tail s2) -- ".." is the leading segment 226 _ -> init s1 ++ norm (joinPath $ tail s2) 227 228-- 229-- misc. 230 231(==>) :: Bool -> Bool -> Bool 232(==>) = (<=) 233infixr 2 ==> 234 235type Warning = String 236 237firstM :: Functor f => (a -> f c) -> (a, b) -> f (c, b) 238firstM f (x,y) = (,y) <$> f x 239 240secondM :: Functor f => (b -> f c) -> (a, b) -> f (a, c) 241secondM f (x,y) = (x,) <$> f y 242 243third3M :: Functor f => (c -> f d) -> (a, b, c) -> f (a, b, d) 244third3M f (x,y,z) = (x,y,) <$> f z 245 246fourth4M :: Functor f => (d -> f e) -> (a, b, c, d) -> f (a, b, c, e) 247fourth4M f (x,y,z,w) = (x,y,z,) <$> f w 248 249fst3 :: (a,b,c) -> a 250fst3 (a,b,c) = a 251 252snd3 :: (a,b,c) -> b 253snd3 (a,b,c) = b 254 255thd3 :: (a,b,c) -> c 256thd3 (a,b,c) = c 257 258fst4 :: (a,b,c,d) -> a 259fst4 (a,b,c,d) = a 260 261for :: [a] -> (a -> b) -> [b] 262for = flip map 263 264 265infixr 3 ***^^ 266(***^^) :: Applicative f => (a -> f a') -> (b -> f b') -> (a, b) -> f (a', b') 267(***^^) fa fb (x,y) = (,) <$> fa x <*> fb y 268 269both :: (a -> b) -> (a, a) -> (b, b) 270both = (Lens.Micro.both %~) 271 272bothM :: Applicative f => (a -> f a') -> (a, a) -> f (a', a') 273bothM f = bitraverse f f 274 275first3 :: (a -> a') -> (a, b, c) -> (a', b, c) 276first3 = (_1 %~) 277 278second3 :: (b -> b') -> (a, b, c) -> (a, b', c) 279second3 = (_2 %~) 280 281third3 :: (c -> c') -> (a, b, c) -> (a, b, c') 282third3 = (_3 %~) 283 284first4 :: (a -> a') -> (a, b, c, d) -> (a', b, c, d) 285first4 = (_1 %~) 286 287second4 :: (b -> b') -> (a, b, c, d) -> (a, b', c, d) 288second4 = (_2 %~) 289 290third4 :: (c -> c') -> (a, b, c, d) -> (a, b, c', d) 291third4 = (_3 %~) 292 293fourth4 :: (d -> d') -> (a, b, c, d) -> (a, b, c, d') 294fourth4 = (_4 %~) 295 296extTup3r :: d -> (a,b,c) -> (a,b,c,d) 297extTup3r d (a,b,c) = (a,b,c,d) 298 299extTup2l :: a -> (b,c) -> (a,b,c) 300extTup2l a (b,c) = (a,b,c) 301 302#if __GLASGOW_HASKELL__ < 803 303concatTup2 :: Monoid a => (a, a) -> a 304#else 305concatTup2 :: Semigroup a => (a, a) -> a 306#endif 307concatTup2 (a1,a2) = a1 <> a2 308 309whenM :: (Monad m, Monoid a) => Bool -> m a -> m a 310whenM b ma = if b then ma else return mempty 311 312whenMM :: (Monad m, Monoid a) => m Bool -> m a -> m a 313whenMM mb ma = mb >>= flip whenM ma 314 315-- modified version of `nubByM' stolen from 316-- <http://hackage.haskell.org/package/monadlist-0.0.2/docs/src/Control-Monad-ListM.html#nubByM> 317nubByM :: (Monad m) => (a -> a -> m Bool) -> [a] -> m [a] 318nubByM f [] = return [] 319nubByM f (x:xs) = liftM (x:) $ filterM (return . not <=< f x) xs >>= nubByM f 320 321-- borrowed from the definitive-base package <http://hackage.haskell.org/package/definitive-base-2.3> 322(<*=) :: Monad m => m a -> (a -> m b) -> m a 323a <*= f = a >>= ((>>) <$> f <*> return) 324 325-- largely borrowed from https://stackoverflow.com/questions/12119420/haskell-ghci-using-eof-character-on-stdin-with-getcontents 326-- NOTE: this is slightly different---it stops after taking the pivoting element 327-- @takeWhileM' c1 c2 ls@: the first condition is the terminating condition for the first line 328-- the second condition is the continuing condition for all lines 329takeWhileM' :: Monad m => (a -> Bool) -> (a -> Bool) -> [m a] -> m [a] 330takeWhileM' _ _ [] = return [] 331takeWhileM' c1 c2 (ma : mas) = do 332 a <- ma 333 if | c1 a -> return [a] 334 | c2 a -> liftM (a :) $ takeWhileM' (const False) c2 mas 335 | otherwise -> return [a] 336 337 338fmapFold :: (Monoid m, Traversable t) => (a -> (m, b)) -> t a -> (m, t b) 339fmapFold f = foldMap (fst . f) &&& fmap (snd . f) 340 341-- NOTE: We need to first apply 'f' so that we are sure 'f' is only executed once; 342-- If we follow the style of the above 'fmapFold' function, which has 'f' twice, 343-- in this monadic function the computation will happen twice, which is undesirable. / zilinc 344fmapFoldM :: (Monoid m, Traversable t, Monad f) => (a -> f (m, b)) -> t a -> f (m, t b) 345fmapFoldM f x = do t <- traverse f x 346 return (foldMap fst t, snd <$> t) 347 348foldMapM :: (Monoid m, Foldable t, Monad f) => (a -> f m) -> t a -> f m 349foldMapM f x = foldrM f' mempty x 350 where f' a b = mappend <$> f a <*> return b 351 352mapAccumLM :: (Monad m) => (a -> b -> m (a,c)) -> a -> [b] -> m (a, [c]) 353mapAccumLM f a (x:xs) = do 354 (a',c) <- f a x 355 fmap (c:) <$> mapAccumLM f a' xs 356mapAccumLM f a [] = pure (a, []) 357 358-- adapted from <http://hackage.haskell.org/package/hydrogen-0.3.0.0/docs/src/H-Util.html#unionWithM> 359unionWithKeyM :: (Ord k, Monad m) => (k -> a -> a -> m a) -> M.Map k a -> M.Map k a -> m (M.Map k a) 360unionWithKeyM f m1 m2 = 361 liftM M.fromList 362 . sequence 363 . fmap (\(k, v) -> liftM (k,) v) 364 . M.toList 365 $ M.unionWithKey f' (M.map return m1) (M.map return m2) 366 where 367 f' k mx my = mx >>= \x -> my >>= \y -> f k x y 368 369-- 370-- useful monad things 371-- 372 373-- Copied from https://hackage.haskell.org/package/errors-2.3.0/docs/src/Control.Error.Util.html 374-- | Lift a 'Maybe' to the 'MaybeT' monad 375hoistMaybe :: (Monad m) => Maybe b -> MaybeT m b 376hoistMaybe = MaybeT . return 377 378 379type WriterMaybe e a = MaybeT (Writer e) a 380 381tellEmpty :: Monoid e => e -> WriterMaybe e a 382tellEmpty e = lift (tell e) >> empty 383 384mapTells :: forall e1 e2 a. (Monoid e1, Monoid e2) => 385 (e1 -> e2) -> 386 WriterMaybe e1 a -> 387 WriterMaybe e2 a 388mapTells f = mapMaybeT (mapWriter (second f)) 389 390-- stdoutPath = "/dev/stdout" 391-- nullPath = "/dev/null" 392 393-- | Used for adding terminators to each line. 394delimiter :: String -> String -> String 395delimiter d = unlines . go d . lines 396 where go d [] = [] 397 go _ [x] = [x] 398 go d (x:xs) = (x++d) : go d xs 399 400 401data Stage = STGParse | STGTypeCheck | STGDesugar | STGNormal | STGSimplify | STGMono | STGCodeGen 402 deriving (Enum, Eq, Ord, Show) 403 404type NameMod = String -> String 405 406 407-- getCogentVersion - returns the version of Cogent 408getCogentVersion = "Cogent development version: " ++ showVersion version ++ suffix ++ 409 "\n" ++ "(" ++ configFlags ++ ")" 410 where 411 suffix = if gitHash == "" then "" else "-" ++ gitHash 412 413-- getCogentVersionWithoutGit - return version of Cogent with git hash 414getCogentVersionWithoutGit = "Cogent version: " ++ showVersion version 415 416-- getStdGumDir 417getHdrsDir :: IO FilePath 418getHdrsDir = do dir <- getDataDir 419 return (dir ++ "/" ++ "lib") 420 421overrideLibgumDirWith :: String -> IO FilePath 422overrideLibgumDirWith envVar = do envValue <- lookupEnv envVar 423 maybe getHdrsDir return envValue 424 425getLibgumDir :: IO String 426getLibgumDir = addTrailingPathSeparator <$> overrideLibgumDirWith "COGENT_LIBGUM_DIR" 427 428getStdIncFullPath fp = do sdir <- getLibgumDir 429 return (sdir </> fp) 430 431-- reads a file, ignoring all lines starting with "--" and blank lines, eliminate spaces 432simpleLineParser :: FilePath -> IO [String] 433simpleLineParser = (return . filter (not . L.isPrefixOf "--") . filter (not . null) . map (dropWhile isSpace) . lines) <=< readFile 434 435 436-- If the domain of some maps contains duplicate keys. 437-- Returns Left ks for overlapping keys ks, Right ks for with the set of non-overlapping keys ks. 438overlapping :: (Eq k) => [M.Map k v] -> Either [k] [k] 439overlapping [] = Right [] 440overlapping (m:ms) = do 441 vs <- overlapping ms 442 let cap = vs `L.intersect` M.keys m 443 if null cap then 444 return (vs `L.union` M.keys m) 445 else 446 Left cap 447 448u8MAX, u16MAX, u32MAX :: Integer 449u8MAX = 256 450u16MAX = 65535 451u32MAX = 4294967296 452 453 454data Bound = GLB | LUB deriving (Eq, Ord) 455 456instance Show Bound where 457 show GLB = "lower bound" 458 show LUB = "upper bound" 459 460theOtherB GLB = LUB 461theOtherB LUB = GLB 462 463 464-- the following are taken from MissingH, BSD3 clause 465-- http://hackage.haskell.org/package/MissingH-1.4.1.0 466spanList :: ([a] -> Bool) -> [a] -> ([a], [a]) 467spanList _ [] = ([],[]) 468spanList func list@(x:xs) = 469 if func list 470 then (x:ys,zs) 471 else ([],list) 472 where (ys,zs) = spanList func xs 473 474breakList :: ([a] -> Bool) -> [a] -> ([a], [a]) 475breakList func = spanList (not . func) 476 477split :: Eq a => [a] -> [a] -> [[a]] 478split _ [] = [] 479split delim str = 480 let (firstline, remainder) = breakList (L.isPrefixOf delim) str 481 in firstline : case remainder of 482 [] -> [] 483 x -> if x == delim 484 then [] : [] 485 else split delim (drop (length delim) x) 486 487replace :: Eq a => [a] -> [a] -> [a] -> [a] 488replace old new l = L.intercalate new . split old $ l 489 490elemBy :: Foldable t => (a -> a -> Bool) -> a -> t a -> Bool 491elemBy f a as = go f a (toList as) 492 where go f a [] = False 493 go f a (b:bs) = if f a b then True else go f a bs 494 495notElemBy :: Foldable t => (a -> a -> Bool) -> a -> t a -> Bool 496notElemBy = ((not .) .) . elemBy 497 498-- | A '\\-by' function 499(\\-) :: (a -> a -> Bool) -> [a] -> [a] -> [a] 500(\\-) f = foldl (flip (L.deleteBy f)) 501 502-- the following are from the extra library, BSD3 503-- http://hackage.haskell.org/package/extra-1.6.13/docs/Control-Monad-Extra.html 504concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] 505concatMapM op = foldr f (return []) 506 where f x xs = do x <- op x; if null x then xs else do xs <- xs; return $ x++xs 507 508allM :: Monad m => (a -> m Bool) -> [a] -> m Bool 509allM p [] = return True 510allM p (x:xs) = do v <- p x; if v then allM p xs else return False 511 512andM :: Monad m => [m Bool] -> m Bool 513andM = allM id 514 515ifThenElse :: Bool -> t -> t -> t 516ifThenElse c e1 e2 = if c then e1 else e2 517 518ifM :: Monad m => m Bool -> m a -> m a -> m a 519ifM b t f = do b <- b; if b then t else f 520 521-- from the errors library, BSD3 522-- http://hackage.haskell.org/package/errors-2.3.0 523exceptT :: Monad m => (a -> m c) -> (b -> m c) -> ExceptT a m b -> m c 524exceptT f g (ExceptT m) = m >>= \z -> case z of 525 Left a -> f a 526 Right b -> g b 527 528-- from composition, BSD3 529-- https://hackage.haskell.org/package/composition-1.0.2.1 530infixr 8 .* 531infixr 8 .** 532 533(.*) :: (c -> d) -> (a -> b -> c) -> a -> b -> d 534(cd .* abc) a b = cd (abc a b) 535 536(.**) :: (d -> e) -> (a -> b -> c -> d) -> a -> b -> c -> e 537(de .** abcd) a b c = de (abcd a b c) 538 539-- Drop the 0-indexed entry and shift everything down by 1. 540behead :: IntMap a -> IntMap a 541behead = IM.mapKeys ((-) 1) . IM.delete 1 542 543infixl 9 .> 544(.>) :: (a -> b) -> (b -> c) -> (a -> c) 545(.>) = flip (.) 546 547