Skip to content

Commit e61a23b

Browse files
tbagrel1tbagrel1
committed
Apply ormolu formatting
1 parent 17e7f4f commit e61a23b

File tree

7 files changed

+169
-168
lines changed

7 files changed

+169
-168
lines changed

‎memory/Compact/Pure.hs‎

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -1,8 +1,8 @@
11
module Compact.Pure (benchmarks) where
22

3-
import Test.Tasty.Bench
43
import Compact.SExpr
54
import GHC.Compact (compact, getCompact)
5+
import Test.Tasty.Bench
66

77
benchmarks :: Benchmark
88
benchmarks =
@@ -12,6 +12,6 @@ benchmarks =
1212
sampleData <- loadSampleData
1313
let res = parseWithoutDest sampleData
1414
resInRegion <- compact res
15-
return $ getCompact resInRegion
16-
, bench "parser using dest" . nfIO $ parseUsingDest <$> loadSampleData
15+
return $ getCompact resInRegion,
16+
bench "parser using dest" . nfIO $ parseUsingDest <$> loadSampleData
1717
]

‎memory/Compact/SExpr.hs‎

Lines changed: 137 additions & 137 deletions
Original file line numberDiff line numberDiff line change
@@ -1,187 +1,187 @@
1-
{-# LANGUAGE MultiWayIf #-}
2-
{-# LANGUAGE DeriveGeneric #-}
1+
{-# LANGUAGE DataKinds #-}
32
{-# LANGUAGE DeriveAnyClass #-}
4-
{-# LANGUAGE TypeApplications #-}
3+
{-# LANGUAGE DeriveGeneric #-}
4+
{-# LANGUAGE ImpredicativeTypes #-}
55
{-# LANGUAGE LambdaCase #-}
66
{-# LANGUAGE LinearTypes #-}
7-
{-# LANGUAGE DataKinds #-}
8-
{-# LANGUAGE ImpredicativeTypes #-}
7+
{-# LANGUAGE MultiWayIf #-}
8+
{-# LANGUAGE TypeApplications #-}
99
{-# LANGUAGE NoImplicitPrelude #-}
1010

1111
module Compact.SExpr where
1212

13+
import Compact.Pure.Internal
14+
import Control.DeepSeq (NFData)
15+
import Control.Functor.Linear ((<$>), (<&>), (>>=))
16+
import Data.Bifunctor.Linear (Bifunctor (second))
1317
import Data.Char (isSpace)
14-
import Text.Read (readMaybe)
18+
import qualified Data.Functor.Linear as Data
1519
import GHC.Generics (Generic)
16-
import Control.DeepSeq (NFData)
17-
import Compact.Pure.Internal
1820
import Prelude.Linear
19-
import qualified Prelude as NonLinear
20-
import Control.Functor.Linear ((<&>), (<$>), (>>=))
21+
import Text.Read (readMaybe)
2122
import Unsafe.Linear (toLinear2)
22-
import Data.Bifunctor.Linear (Bifunctor(second))
23-
import qualified Data.Functor.Linear as Data
23+
import qualified Prelude as NonLinear
2424

2525
loadSampleData :: IO String
2626
loadSampleData = readFile "memory/Compact/test_data.sexpr"
2727

2828
data SExpr
29-
= SList [SExpr]
30-
| SFloat Float
31-
| SInteger Int
32-
| SString String
33-
| SSymbol String
34-
deriving (Eq, Generic, NFData)
29+
= SList [SExpr]
30+
| SFloat Float
31+
| SInteger Int
32+
| SString String
33+
| SSymbol String
34+
deriving (Eq, Generic, NFData)
3535

3636
showSExpr :: Bool -> Int -> SExpr %1 -> String
3737
showSExpr cont indent = \case
38-
SList [] -> makeIndent cont indent ++ "()"
39-
SList (x:xs) ->
40-
makeIndent cont indent
41-
++ "("
42-
++ showSExpr True (indent + 1) x
43-
++ concatMap (\x -> "\n" ++ showSExpr False (indent + 1) x) xs
44-
++ ")"
45-
SFloat f -> makeIndent cont indent ++ show f
46-
SInteger i -> makeIndent cont indent ++ show i
47-
SString s -> makeIndent cont indent ++ show s
48-
SSymbol s -> makeIndent cont indent ++ s
49-
where
50-
makeIndent cont indent = if cont then "" else replicate indent ' '
38+
SList [] -> makeIndent cont indent ++ "()"
39+
SList (x : xs) ->
40+
makeIndent cont indent
41+
++ "("
42+
++ showSExpr True (indent + 1) x
43+
++ concatMap (\x -> "\n" ++ showSExpr False (indent + 1) x) xs
44+
++ ")"
45+
SFloat f -> makeIndent cont indent ++ show f
46+
SInteger i -> makeIndent cont indent ++ show i
47+
SString s -> makeIndent cont indent ++ show s
48+
SSymbol s -> makeIndent cont indent ++ s
49+
where
50+
makeIndent cont indent = if cont then "" else replicate indent ' '
5151

5252
instance Show SExpr where
53-
show x = showSExpr False 0 x
53+
show x = showSExpr False 0 x
5454

5555
data SContext
56-
= NotInSList
57-
| InSList [SExpr]
58-
deriving (Eq, Generic, NFData)
56+
= NotInSList
57+
| InSList [SExpr]
58+
deriving (Eq, Generic, NFData)
5959

6060
data DSContext r
61-
= DNotInSList (Dest SExpr r)
62-
| DInSList (Dest [SExpr] r)
61+
= DNotInSList (Dest SExpr r)
62+
| DInSList (Dest [SExpr] r)
6363

6464
data SExprParseError
65-
= UnexpectedClosingParen String
66-
| UnexpectedEOFSExpr
67-
| UnexpectedEOFSList (Maybe [SExpr])
68-
| UnexpectedEOFSString Bool (Maybe String)
69-
| UnexpectedContentAfter SExpr (Maybe String)
70-
deriving (Eq, Generic, NFData)
65+
= UnexpectedClosingParen String
66+
| UnexpectedEOFSExpr
67+
| UnexpectedEOFSList (Maybe [SExpr])
68+
| UnexpectedEOFSString Bool (Maybe String)
69+
| UnexpectedContentAfter SExpr (Maybe String)
70+
deriving (Eq, Generic, NFData)
7171

7272
instance Show SExprParseError where
73-
show = \case
74-
UnexpectedClosingParen remaining ->
75-
"Parse error: Encountered an unexpected closing parentheses in:\n"
76-
++ remaining
77-
UnexpectedEOFSExpr -> "Parse error: Ecountered EOF while expecting an SExpr."
78-
UnexpectedEOFSList mContext ->
79-
"Parse error: Encountered EOF in the middle of parsing an SList.\n"
80-
++ ifAvailableShow mContext "\n"
81-
UnexpectedEOFSString escaped mContext ->
82-
"Parse error: Encountered EOF in the middle of parsing a quoted string\n"
83-
++ "Escape mode for next character: "
84-
++ (if escaped then "on" else "off")
85-
++ ifAvailableShow mContext "\nThese chars have been parsed so far: "
86-
UnexpectedContentAfter parsedExpr mContext ->
87-
"Parse error: This SExpr has been successfully parsed:\n"
88-
++ show parsedExpr
89-
++ "\nBut some unexpected content is present after"
90-
++ ifAvailableShow mContext ":\n"
91-
where
92-
ifAvailableShow :: (Show a) => Maybe a -> String -> String
93-
ifAvailableShow mContext header = case mContext of
94-
Nothing -> ""
95-
Just c -> header ++ show c
96-
73+
show = \case
74+
UnexpectedClosingParen remaining ->
75+
"Parse error: Encountered an unexpected closing parentheses in:\n"
76+
++ remaining
77+
UnexpectedEOFSExpr -> "Parse error: Ecountered EOF while expecting an SExpr."
78+
UnexpectedEOFSList mContext ->
79+
"Parse error: Encountered EOF in the middle of parsing an SList.\n"
80+
++ ifAvailableShow mContext "\n"
81+
UnexpectedEOFSString escaped mContext ->
82+
"Parse error: Encountered EOF in the middle of parsing a quoted string\n"
83+
++ "Escape mode for next character: "
84+
++ (if escaped then "on" else "off")
85+
++ ifAvailableShow mContext "\nThese chars have been parsed so far: "
86+
UnexpectedContentAfter parsedExpr mContext ->
87+
"Parse error: This SExpr has been successfully parsed:\n"
88+
++ show parsedExpr
89+
++ "\nBut some unexpected content is present after"
90+
++ ifAvailableShow mContext ":\n"
91+
where
92+
ifAvailableShow :: (Show a) => Maybe a -> String -> String
93+
ifAvailableShow mContext header = case mContext of
94+
Nothing -> ""
95+
Just c -> header ++ show c
9796

9897
readStringWithoutDest :: String -> Bool -> String -> Either SExprParseError (SExpr, String)
9998
readStringWithoutDest = \cases
100-
acc escaped [] -> Left $ UnexpectedEOFSString escaped (Just acc)
101-
acc True ('n' : xs) -> readStringWithoutDest ('\n' : acc) False xs -- TODO: add other escape chars
102-
acc False ('\\' : xs) -> readStringWithoutDest acc True xs
103-
acc False ('"' : xs) -> Right $ (SString $ reverse acc, xs)
104-
acc _ (x : xs) -> readStringWithoutDest (x : acc) False xs
99+
acc escaped [] -> Left $ UnexpectedEOFSString escaped (Just acc)
100+
acc True ('n' : xs) -> readStringWithoutDest ('\n' : acc) False xs -- TODO: add other escape chars
101+
acc False ('\\' : xs) -> readStringWithoutDest acc True xs
102+
acc False ('"' : xs) -> Right $ (SString $ reverse acc, xs)
103+
acc _ (x : xs) -> readStringWithoutDest (x : acc) False xs
105104

106105
parseWithoutDest' :: SContext -> String -> Either SExprParseError (SExpr, String)
107106
parseWithoutDest' = \cases
108-
NotInSList [] -> Left $ UnexpectedEOFSExpr
109-
(InSList exprs) [] -> Left $ UnexpectedEOFSList (Just exprs)
110-
ctx s@(x:xs) -> case x of
111-
'(' -> appendOrRet ctx $ parseWithoutDest' (InSList []) xs
112-
')' -> case ctx of
113-
InSList exprs -> Right (SList $ reverse exprs, xs)
114-
NotInSList -> Left $ UnexpectedClosingParen s
115-
'"' -> appendOrRet ctx $ readStringWithoutDest [] False xs
116-
_ -> if isSpace x
117-
then parseWithoutDest' ctx xs
118-
else case NonLinear.break (\c -> isSpace c || c `NonLinear.elem` ['(', ')', '"']) s of
119-
(raw, remaining) -> case readMaybe @Int raw of
120-
Just int -> appendOrRet ctx $ Right (SInteger int, remaining)
121-
Nothing -> case readMaybe @Float raw of
122-
Just float -> appendOrRet ctx $ Right (SFloat float, remaining)
123-
Nothing -> appendOrRet ctx $ Right (SSymbol raw, remaining)
124-
where
125-
appendOrRet :: SContext -> Either SExprParseError (SExpr, String) -> Either SExprParseError (SExpr, String)
126-
appendOrRet = \cases
127-
(InSList exprs) (Right (expr, remaining)) -> parseWithoutDest' (InSList $ expr : exprs) remaining
128-
_ res -> res -- left is Nothing or right is error
107+
NotInSList [] -> Left $ UnexpectedEOFSExpr
108+
(InSList exprs) [] -> Left $ UnexpectedEOFSList (Just exprs)
109+
ctx s@(x : xs) -> case x of
110+
'(' -> appendOrRet ctx $ parseWithoutDest' (InSList []) xs
111+
')' -> case ctx of
112+
InSList exprs -> Right (SList $ reverse exprs, xs)
113+
NotInSList -> Left $ UnexpectedClosingParen s
114+
'"' -> appendOrRet ctx $ readStringWithoutDest [] False xs
115+
_ ->
116+
if isSpace x
117+
then parseWithoutDest' ctx xs
118+
else case NonLinear.break (\c -> isSpace c || c `NonLinear.elem` ['(', ')', '"']) s of
119+
(raw, remaining) -> case readMaybe @Int raw of
120+
Just int -> appendOrRet ctx $ Right (SInteger int, remaining)
121+
Nothing -> case readMaybe @Float raw of
122+
Just float -> appendOrRet ctx $ Right (SFloat float, remaining)
123+
Nothing -> appendOrRet ctx $ Right (SSymbol raw, remaining)
124+
where
125+
appendOrRet :: SContext -> Either SExprParseError (SExpr, String) -> Either SExprParseError (SExpr, String)
126+
appendOrRet = \cases
127+
(InSList exprs) (Right (expr, remaining)) -> parseWithoutDest' (InSList $ expr : exprs) remaining
128+
_ res -> res -- left is Nothing or right is error
129129

130130
parseWithoutDest :: String -> Either SExprParseError SExpr
131131
parseWithoutDest s = case parseWithoutDest' NotInSList s of
132-
Right (expr, remaining) | NonLinear.all isSpace remaining -> Right expr
133-
Right (expr, remaining) -> Left $ UnexpectedContentAfter expr (Just remaining)
134-
Left err -> Left err
132+
Right (expr, remaining) | NonLinear.all isSpace remaining -> Right expr
133+
Right (expr, remaining) -> Left $ UnexpectedContentAfter expr (Just remaining)
134+
Left err -> Left err
135135

136136
defaultSExpr :: SExpr
137137
defaultSExpr = SInteger 0
138138

139139
readStringUsingDest :: Dest String r %1 -> Bool -> String -> Either (Ur SExprParseError) String
140140
readStringUsingDest = \cases
141-
d escaped [] -> d <| C @"[]" `lseq` Left (Ur $ UnexpectedEOFSString escaped Nothing)
142-
d True ('n' : xs) -> case d <| C @":" of (dx, dxs) -> dx <|.. '\n' `lseq` readStringUsingDest dxs False xs -- TODO: add other escape chars
143-
d False ('\\' : xs) -> readStringUsingDest d True xs
144-
d False ('"' : xs) -> d <| C @"[]" `lseq` Right xs
145-
d _ (x : xs) -> case d <| C @":" of (dx, dxs) -> dx <|.. x `lseq` readStringUsingDest dxs False xs
141+
d escaped [] -> d <| C @"[]" `lseq` Left (Ur $ UnexpectedEOFSString escaped Nothing)
142+
d True ('n' : xs) -> case d <| C @":" of (dx, dxs) -> dx <|.. '\n' `lseq` readStringUsingDest dxs False xs -- TODO: add other escape chars
143+
d False ('\\' : xs) -> readStringUsingDest d True xs
144+
d False ('"' : xs) -> d <| C @"[]" `lseq` Right xs
145+
d _ (x : xs) -> case d <| C @":" of (dx, dxs) -> dx <|.. x `lseq` readStringUsingDest dxs False xs
146146

147147
parseUsingDest' :: DSContext r %1 -> String -> Either (Ur SExprParseError) String
148148
parseUsingDest' = \cases
149-
(DNotInSList d) [] -> d <|.. defaultSExpr `lseq` Left $ Ur UnexpectedEOFSExpr
150-
(DInSList d) [] -> d <| C @"[]" `lseq` Left (Ur $ UnexpectedEOFSList Nothing)
151-
ctx s@(x:xs) -> case x of
152-
'(' -> appendOrRet ctx (\dExpr -> parseUsingDest' (DInSList $ dExpr <| C @"SList")) xs
153-
')' -> case ctx of
154-
DInSList d -> d <| C @"[]" `lseq` Right xs
155-
DNotInSList d -> d <|.. defaultSExpr `lseq` Left (Ur $ UnexpectedClosingParen s)
156-
'"' -> appendOrRet ctx (\dExpr -> readStringUsingDest (dExpr <| C @"SString") False) xs
157-
_ -> if isSpace x
158-
then parseUsingDest' ctx xs
159-
else case NonLinear.break (\c -> isSpace c || c `NonLinear.elem` ['(', ')', '"']) s of
160-
(raw, remaining) -> case readMaybe @Int raw of
161-
Just int -> appendOrRet ctx (\dExpr -> dExpr <| C @"SInteger" <|.. int `lseq` Right) remaining
162-
Nothing -> case readMaybe @Float raw of
163-
Just float -> appendOrRet ctx (\dExpr -> dExpr <| C @"SFloat" <|.. float `lseq` Right) remaining
164-
Nothing -> appendOrRet ctx (\dExpr -> dExpr <| C @"SSymbol" <|.. raw `lseq` Right) remaining
165-
where
166-
appendOrRet :: DSContext r %1 -> (Dest SExpr r %1 -> String -> Either (Ur SExprParseError) String) %1 -> String -> Either (Ur SExprParseError) String
167-
appendOrRet ctx f s = case ctx of
168-
DNotInSList d -> f d s
169-
DInSList d ->
170-
case d <| C @":" of
171-
(dExpr, dRem) -> case f dExpr s of
172-
Right s' -> parseUsingDest' (DInSList dRem) s'
173-
Left err -> dRem <| C @"[]" `lseq` Left err
149+
(DNotInSList d) [] -> d <|.. defaultSExpr `lseq` Left $ Ur UnexpectedEOFSExpr
150+
(DInSList d) [] -> d <| C @"[]" `lseq` Left (Ur $ UnexpectedEOFSList Nothing)
151+
ctx s@(x : xs) -> case x of
152+
'(' -> appendOrRet ctx (\dExpr -> parseUsingDest' (DInSList $ dExpr <| C @"SList")) xs
153+
')' -> case ctx of
154+
DInSList d -> d <| C @"[]" `lseq` Right xs
155+
DNotInSList d -> d <|.. defaultSExpr `lseq` Left (Ur $ UnexpectedClosingParen s)
156+
'"' -> appendOrRet ctx (\dExpr -> readStringUsingDest (dExpr <| C @"SString") False) xs
157+
_ ->
158+
if isSpace x
159+
then parseUsingDest' ctx xs
160+
else case NonLinear.break (\c -> isSpace c || c `NonLinear.elem` ['(', ')', '"']) s of
161+
(raw, remaining) -> case readMaybe @Int raw of
162+
Just int -> appendOrRet ctx (\dExpr -> dExpr <| C @"SInteger" <|.. int `lseq` Right) remaining
163+
Nothing -> case readMaybe @Float raw of
164+
Just float -> appendOrRet ctx (\dExpr -> dExpr <| C @"SFloat" <|.. float `lseq` Right) remaining
165+
Nothing -> appendOrRet ctx (\dExpr -> dExpr <| C @"SSymbol" <|.. raw `lseq` Right) remaining
166+
where
167+
appendOrRet :: DSContext r %1 -> (Dest SExpr r %1 -> String -> Either (Ur SExprParseError) String) %1 -> String -> Either (Ur SExprParseError) String
168+
appendOrRet ctx f s = case ctx of
169+
DNotInSList d -> f d s
170+
DInSList d ->
171+
case d <| C @":" of
172+
(dExpr, dRem) -> case f dExpr s of
173+
Right s' -> parseUsingDest' (DInSList dRem) s'
174+
Left err -> dRem <| C @"[]" `lseq` Left err
174175

175176
parseUsingDest :: String -> Either SExprParseError SExpr
176177
parseUsingDest s =
177-
case withRegion $ \r ->
178-
case completeExtract $ alloc r <&> DNotInSList <&> flip parseUsingDest' s <&> finalizeResults of
179-
Ur (expr, Right ()) -> Ur (Right expr)
180-
Ur (expr, Left errFn) -> Ur (Left $ errFn expr)
181-
of
182-
Ur res -> res
183-
where
184-
finalizeResults :: Either (Ur SExprParseError) String %1 -> Ur (Either (SExpr -> SExprParseError) ())
185-
finalizeResults = \case
186-
Right s -> move s & \case Ur s' -> if NonLinear.all isSpace s' then Ur (Right ()) else Ur (Left $ \expr -> UnexpectedContentAfter expr (Just s'))
187-
Left (Ur err) -> Ur (Left $ const err)
178+
case withRegion $ \r ->
179+
case completeExtract $ alloc r <&> DNotInSList <&> flip parseUsingDest' s <&> finalizeResults of
180+
Ur (expr, Right ()) -> Ur (Right expr)
181+
Ur (expr, Left errFn) -> Ur (Left $ errFn expr) of
182+
Ur res -> res
183+
where
184+
finalizeResults :: Either (Ur SExprParseError) String %1 -> Ur (Either (SExpr -> SExprParseError) ())
185+
finalizeResults = \case
186+
Right s -> move s & \case Ur s' -> if NonLinear.all isSpace s' then Ur (Right ()) else Ur (Left $ \expr -> UnexpectedContentAfter expr (Just s'))
187+
Left (Ur err) -> Ur (Left $ const err)

‎memory/Main.hs‎

Lines changed: 1 addition & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,9 +1,8 @@
11
module Main (main) where
22

33
import qualified Compact.Pure as Compact
4-
5-
import Test.Tasty.Bench (defaultMain)
64
import Compact.SExpr
5+
import Test.Tasty.Bench (defaultMain)
76

87
-- Launch with
98
-- stack bench linear-base:bench:memory --ba '+RTS -T'

0 commit comments

Comments
 (0)