~jojo/Carth

ref: 4787862839d89f42711d9e708a5af3e5f5f7311a Carth/src/Misc.hs -rw-r--r-- 3.4 KiB
47878628JoJo Simplify Codegen by using classes for the tail-call stuff 3 months ago
                                                                                
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
module Misc where

import Data.List (intercalate)
import qualified Data.Map as Map
import Data.Map (Map)
import Data.Maybe
import Data.Bifunctor
import Control.Monad.Reader
import Control.Monad.Writer
import Control.Monad.State.Strict
import Lens.Micro.Platform (Lens, Lens', over, set, use, modifying)
import Data.Bitraversable
import System.Exit
import qualified Text.Megaparsec as Mega
import Text.Megaparsec hiding (parse, match)
import Text.Megaparsec.Char hiding (space, space1)
import Data.Void


newtype TopologicalOrder a = Topo [a]
    deriving Show

type Source = String


ice :: String -> a
ice = error . ("Internal Compiler Error: " ++)

nyi :: String -> a
nyi = error . ("Not yet implemented: " ++)

-- | Like `intercalate`, but concatenate a list with a prefix before each
--   element, instead of an separator between each pair of elements.
precalate :: [a] -> [[a]] -> [a]
precalate prefix = \case
    [] -> []
    xs -> prefix ++ intercalate prefix xs

indent :: Int -> String
indent = flip replicate ' '

both :: (a -> b) -> (a, a) -> (b, b)
both f (a0, a1) = (f a0, f a1)

firstM :: (Bitraversable t, Applicative f) => (a -> f a') -> t a b -> f (t a' b)
firstM = flip bimapM pure

secondM :: (Bitraversable t, Applicative f) => (b -> f b') -> t a b -> f (t a b')
secondM = bimapM pure

locallySet :: MonadReader s m => Lens' s a -> a -> m r -> m r
locallySet l = locally l . const

locally :: MonadReader s m => Lens' s a -> (a -> a) -> m r -> m r
locally l f = local (over l f)

augment1 :: (MonadReader e m, Ord k) => Lens' e (Map k v) -> (k, v) -> m a -> m a
augment1 l = locally l . uncurry Map.insert

augment :: (MonadReader s m, Monoid a) => Lens' s a -> a -> m x -> m x
augment l = locally l . mappend

scribe :: (MonadWriter t m, Monoid s) => Lens s t a b -> b -> m ()
scribe l b = tell (set l b mempty)

(<<+=) :: (MonadState s m, Num a) => Lens' s a -> a -> m a
(<<+=) l n = use l <* modifying l (+ n)

(.*) :: (c -> d) -> (a -> b -> c) -> a -> b -> d
(.*) = (.) . (.)
infixr 8 .*

(.**) :: (d -> e) -> (a -> b -> c -> d) -> a -> b -> c -> e
(.**) = (.) . (.*)
infixr 8 .**

abort :: FilePath -> IO a
abort f = do
    putStrLn "Error: Aborting due to previous error."
    putStrLn $ "Error: Could not compile " ++ f ++ "."
    exitFailure

splitOn :: String -> String -> [String]
splitOn sep = fromMaybe [] . Mega.parseMaybe splitOn'
  where
    splitOn' :: Parsec Void String [String]
    splitOn' = do
        as <- many (try (manyTill anySingle (try (string sep))))
        a <- many anySingle
        pure $ (as ++) $ if not (null a) then [a] else []

parse' :: Parsec Void String a -> FilePath -> Source -> Either String a
parse' p name src = first errorBundlePretty (Mega.parse p name src)

partitionWith :: (a -> Either b c) -> [a] -> ([b], [c])
partitionWith f = foldr
    (\x (bs, cs) -> case f x of
        Left b -> (b : bs, cs)
        Right c -> (bs, c : cs)
    )
    ([], [])

rightToMaybe :: Either a b -> Maybe b
rightToMaybe = either (const Nothing) Just

unsnoc :: [a] -> Maybe ([a], a)
unsnoc = \case
    [] -> Nothing
    x : xs -> case unsnoc xs of
        Just (ys, y) -> Just (x : ys, y)
        Nothing -> Just ([], x)

is2tup :: [a] -> Maybe (a, a)
is2tup = \case
    a1 : [a2] -> Just (a1, a2)
    _ -> Nothing

is3tup :: [a] -> Maybe (a, a, a)
is3tup = \case
    a1 : a2 : [a3] -> Just (a1, a2, a3)
    _ -> Nothing

takeWhileJust :: (a -> Maybe b) -> [a] -> [b]
takeWhileJust f = \case
    [] -> []
    a : as -> maybe [] (: takeWhileJust f as) (f a)