this sucks lol
This commit is contained in:
@@ -77,6 +77,7 @@ Eof : eof { () }
|
|||||||
|
|
||||||
StandaloneProgram :: { Program Name }
|
StandaloneProgram :: { Program Name }
|
||||||
StandaloneProgram : Program eof { $1 }
|
StandaloneProgram : Program eof { $1 }
|
||||||
|
| eof { mempty }
|
||||||
|
|
||||||
Program :: { Program Name }
|
Program :: { Program Name }
|
||||||
Program : ScTypeSig ';' Program { insTypeSig $1 $3 }
|
Program : ScTypeSig ';' Program { insTypeSig $1 $3 }
|
||||||
|
|||||||
@@ -17,9 +17,10 @@ import Test.QuickCheck
|
|||||||
|
|
||||||
spec :: Spec
|
spec :: Spec
|
||||||
spec = do
|
spec = do
|
||||||
it "should be a right-inverse to the unparser\
|
it "should be a right-inverse to the unparser \
|
||||||
\up to source code congruency" $
|
\up to source code congruency" $
|
||||||
property $ \p -> (unparse <=< parse) p ~== Right p
|
withMaxSuccess 20 $ property $
|
||||||
|
\p -> (unparse <=< parse) p ~== Right p
|
||||||
|
|
||||||
-- TODO: abitrary ASTs
|
-- TODO: abitrary ASTs
|
||||||
-- it "should be a right-inverse to the unparser\
|
-- it "should be a right-inverse to the unparser\
|
||||||
|
|||||||
@@ -25,7 +25,7 @@ import Lens.Micro.Platform.Internal (IsText(..))
|
|||||||
----------------------------------------------------------------------------------
|
----------------------------------------------------------------------------------
|
||||||
|
|
||||||
newtype ProgramSrc = ProgramSrc Text
|
newtype ProgramSrc = ProgramSrc Text
|
||||||
deriving (Show, Eq, Semigroup, Monoid, IsString)
|
deriving (Show, Read, Eq, Semigroup, Monoid, IsString)
|
||||||
|
|
||||||
instance Arbitrary ProgramSrc where
|
instance Arbitrary ProgramSrc where
|
||||||
arbitrary = sized genProg where
|
arbitrary = sized genProg where
|
||||||
@@ -68,8 +68,8 @@ instance Arbitrary ProgramSrc where
|
|||||||
, wrapParens <$> gen n' 0
|
, wrapParens <$> gen n' 0
|
||||||
, genApp n p
|
, genApp n p
|
||||||
, genLet n p
|
, genLet n p
|
||||||
, genLam n p
|
-- , genLam n p
|
||||||
, genCase n p
|
-- , genCase n p
|
||||||
]
|
]
|
||||||
where n' = next n
|
where n' = next n
|
||||||
|
|
||||||
@@ -114,7 +114,7 @@ instance Arbitrary ProgramSrc where
|
|||||||
var = oneof [genName, wrapParens <$> genSymName]
|
var = oneof [genName, wrapParens <$> genSymName]
|
||||||
n' = next n
|
n' = next n
|
||||||
|
|
||||||
genLam n p = conseq [l, ws, bs, pure "->", ws, gen n' 0]
|
genLam n p = conseq [l, ws, bs, ws, pure "->", ws, gen n' 0]
|
||||||
<&> pprec 0 p
|
<&> pprec 0 p
|
||||||
where
|
where
|
||||||
-- whitespace because reserved op shenanigans :3
|
-- whitespace because reserved op shenanigans :3
|
||||||
@@ -207,6 +207,11 @@ congruentSrc = (==) `on` (justParseSrc . T.unpack . coerce)
|
|||||||
|
|
||||||
----------------------------------------------------------------------------------
|
----------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
-- TODO: unparseCoreProg :: Program -> [CoreToken]
|
||||||
|
-- womp womp.
|
||||||
|
|
||||||
|
-- TODO: implement shrink
|
||||||
|
|
||||||
-- | @unparseCoreProg@ should be inverse to @parseCoreProg@ up to source code
|
-- | @unparseCoreProg@ should be inverse to @parseCoreProg@ up to source code
|
||||||
-- congruency, newtype coercion and errors handling.
|
-- congruency, newtype coercion and errors handling.
|
||||||
unparseCoreProg :: Program' -> ProgramSrc
|
unparseCoreProg :: Program' -> ProgramSrc
|
||||||
@@ -221,7 +226,9 @@ unparseTypeSig :: Name -> Type -> ProgramSrc
|
|||||||
unparseTypeSig n t = unparseName n <> " :: " <> unparseType t
|
unparseTypeSig n t = unparseName n <> " :: " <> unparseType t
|
||||||
|
|
||||||
unparseName :: Name -> ProgramSrc
|
unparseName :: Name -> ProgramSrc
|
||||||
unparseName = coerce
|
unparseName n
|
||||||
|
| T.head n `elem` (':' : nameSymbols) = coerce $ wrapParens n
|
||||||
|
| otherwise = coerce n
|
||||||
|
|
||||||
unparseType :: Type -> ProgramSrc
|
unparseType :: Type -> ProgramSrc
|
||||||
unparseType = go 0 where
|
unparseType = go 0 where
|
||||||
@@ -267,6 +274,7 @@ unparseExpr = go 0 where
|
|||||||
<> " -> " <> go 0 e
|
<> " -> " <> go 0 e
|
||||||
& pprec 0 p
|
& pprec 0 p
|
||||||
go p (Let r bs e) = mconcat [lw," { ",bs'," } in ",go 0 e]
|
go p (Let r bs e) = mconcat [lw," { ",bs'," } in ",go 0 e]
|
||||||
|
& pprec 0 p
|
||||||
where
|
where
|
||||||
lw = case r of { NonRec -> "let"; Rec -> "letrec" }
|
lw = case r of { NonRec -> "let"; Rec -> "letrec" }
|
||||||
bs' = srci "; " $ unparseBinding <$> bs
|
bs' = srci "; " $ unparseBinding <$> bs
|
||||||
|
|||||||
@@ -21,7 +21,7 @@ spec = do
|
|||||||
resultOf [coreProg|id x = x; main = (id (-#)) 3 2;|] `shouldBe` Just (NNum 1)
|
resultOf [coreProg|id x = x; main = (id (-#)) 3 2;|] `shouldBe` Just (NNum 1)
|
||||||
|
|
||||||
it "should correctly evaluate arbitrary arithmetic" $ do
|
it "should correctly evaluate arbitrary arithmetic" $ do
|
||||||
property $ \e ->
|
withMaxSuccess 40 $ property $ \e ->
|
||||||
let arithRes = Just (evalArith e)
|
let arithRes = Just (evalArith e)
|
||||||
coreRes = evalCore e
|
coreRes = evalCore e
|
||||||
in coreRes `shouldBe` arithRes
|
in coreRes `shouldBe` arithRes
|
||||||
|
|||||||
Reference in New Issue
Block a user