blob: f59f7a7bc888abafad01051d4d2dc22ee6f82149 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
|
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE EmptyCase #-}
module LambdaCube.Compiler.Utils where
import qualified Data.IntSet as IS
import qualified Data.Text as T
import qualified Text.Show.Pretty as PP
import Control.Monad.Catch
import Control.Monad.Except
import System.Directory
import qualified Data.Text.IO as TIO
------------------------------------------------------- general functions
(<&>) = flip (<$>)
dropNth i xs = take i xs ++ drop (i+1) xs
iterateN n f e = iterate f e !! n
unfoldNat z s 0 = z
unfoldNat z s n | n > 0 = s $ unfoldNat z s (n-1)
------------------------------------------------------- Void data type
data Void
instance Show Void where show = elimVoid
instance Eq Void where x == y = elimVoid x
elimVoid :: Void -> a
elimVoid v = case v of
------------------------------------------------------- supplementary data wrapper
-- supplementary data: data with no semantic relevance
newtype SData a = SData a
instance Show (SData a) where show _ = "SData"
instance Eq (SData a) where _ == _ = True
instance Ord (SData a) where _ `compare` _ = EQ
------------------------------------------------------- strongly connected component calculation
type Children k = k -> [k]
data Task a = Return a | Visit a
scc :: forall k . (k -> Int) -> Children k -> Children k -> [k]{-roots-} -> [[k]]
scc key children revChildren
= filter (not . null) . uncurry (revMapWalk revChildren) . revPostOrderWalk children
where
revPostOrderWalk :: Children k -> [k] -> (IS.IntSet, [k])
revPostOrderWalk children = collect IS.empty [] . map Visit where
collect s acc [] = (s, acc)
collect s acc (Return h: t) = collect s (h: acc) t
collect s acc (Visit h: t)
| key h `IS.member` s = collect s acc t
| otherwise = collect (IS.insert (key h) s) acc $ map Visit (children h) ++ Return h: t
revMapWalk :: Children k -> IS.IntSet -> [k] -> [[k]]
revMapWalk children = f []
where
f acc s [] = acc
f acc s (h:t) = f (c: acc) s' t
where (s', c) = collect s [] [h]
collect s acc [] = (s, acc)
collect s acc (h:t)
| not (key h `IS.member` s) = collect s acc t
| otherwise = collect (IS.delete (key h) s) (h: acc) (children h ++ t)
------------------------------------------------------- wrapped pretty show
prettyShowUnlines :: Show a => a -> String
prettyShowUnlines = goPP 0 . PP.ppShow
where
goPP _ [] = []
goPP n ('"':xs) | isMultilineString xs = "\"\"\"\n" ++ indent ++ go xs where
indent = replicate n ' '
go ('\\':'n':xs) = "\n" ++ indent ++ go xs
go ('\\':c:xs) = '\\':c:go xs
go ('"':xs) = "\n" ++ indent ++ "\"\"\"" ++ goPP n xs
go (x:xs) = x : go xs
goPP n (x:xs) = x : goPP (if x == '\n' then 0 else n+1) xs
isMultilineString ('\\':'n':xs) = True
isMultilineString ('\\':c:xs) = isMultilineString xs
isMultilineString ('"':xs) = False
isMultilineString (x:xs) = isMultilineString xs
isMultilineString [] = False
------------------------------------------------------- file handling
readFileStrict :: FilePath -> IO String
readFileStrict = fmap T.unpack . TIO.readFile
readFileIfExists :: FilePath -> IO (Maybe (IO String))
readFileIfExists fname = do
b <- doesFileExist fname
return $ if b then Just $ readFileStrict fname else Nothing
instance MonadMask m => MonadMask (ExceptT e m) where
mask f = ExceptT $ mask $ \u -> runExceptT $ f (mapExceptT u)
uninterruptibleMask = error "not implemented: uninterruptibleMask for ExcpetT"
|
