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
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
|
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
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 Control.Monad.RWS
import System.Directory
import qualified Data.Text.IO as TIO
import qualified Text.Megaparsec as P
import qualified Text.Megaparsec.Prim as P
------------------------------------------------------- general functions
(<&>) :: Functor f => f a -> (a -> b) -> f b
(<&>) = flip (<$>)
dropIndex :: Int -> [a] -> [a]
dropIndex i xs = take i xs ++ drop (i+1) xs
iterateN :: Int -> (a -> a) -> a -> a
iterateN n f e = iterate f e !! n
unfoldNat :: Integral n => a -> (a -> a) -> n -> a
unfoldNat z s 0 = z
unfoldNat z s n | n > 0 = s $ unfoldNat z s (n-1)
mfix' f = ExceptT (mfix (runExceptT . f . either bomb id))
where bomb e = error $ "mfix (ExceptT): inner computation returned Left value:\n" ++ show e
foldlrev f = foldr (flip f)
------------------------------------------------------- Void data type
data Void
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 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
------------------------------------------------------- missing instances
instance MonadMask m => MonadMask (ExceptT e m) where
mask f = ExceptT $ mask $ \u -> runExceptT $ f (mapExceptT u)
uninterruptibleMask = error "not implemented: uninterruptibleMask for ExcpetT"
instance (Monoid w, P.MonadParsec st m t) => P.MonadParsec st (RWST r w s m) t where
failure = lift . P.failure
label = mapRWST . P.label
try = mapRWST P.try
lookAhead (RWST m) = RWST $ \r s -> (\(a, _, _) -> (a, s, mempty)) <$> P.lookAhead (m r s)
notFollowedBy (RWST m) = RWST $ \r s -> P.notFollowedBy ((\(a, _, _) -> a) <$> m r s) >> return ((), s, mempty)
withRecovery rec (RWST m) = RWST $ \r s -> P.withRecovery (\e -> runRWST (rec e) r s) (m r s)
eof = lift P.eof
token f e = lift $ P.token f e
tokens f e ts = lift $ P.tokens f e ts
getParserState = lift P.getParserState
updateParserState f = lift $ P.updateParserState f
|
