{-# Language FlexibleInstances #-}
module Main where
import Control.Monad (unless)
import Data.Either.Validation (Validation(..))
import Data.Functor.Identity (Identity(Identity))
import Data.List (isSuffixOf)
import Data.List.NonEmpty (NonEmpty((:|)))
import Data.Text (Text, unpack)
import Data.Text.IO (readFile)
import Data.Text.Prettyprint.Doc (Pretty(pretty), layoutPretty, defaultLayoutOptions)
import Data.Text.Prettyprint.Doc.Render.Text (renderStrict)
import System.Directory (doesDirectoryExist, listDirectory)
import System.FilePath.Posix (combine)
import Test.Tasty (TestTree, defaultMain, testGroup)
import Test.Tasty.HUnit (assertFailure, assertEqual, testCase)
import Text.Grampa (failureDescription)
import qualified Transformation.Rank2 as Rank2
import qualified Language.Oberon.Reserializer as Reserializer
import Language.Modula2 (parseModule, parseAndSimplifyModule, Placed, Version(..))
import Language.Modula2.AST (Language, Module)
import qualified Language.Modula2.ISO.AST as ISO (Language)
import qualified Language.Modula2.ConstantFolder -- brings in HasField instances
import qualified Language.Modula2.ISO.ConstantFolder -- brings in HasField instances
import Prelude hiding (readFile)
main = exampleTree "" "examples/" >>= defaultMain . testGroup "Modula-2"
width = 80
contextLines = 3
unparsables = map ("examples/Modula-2_Libraries/" <>)
["andrea-m2/applications/eth-hamburg/life/lifemodul.def",
"andrea-m2/examples/generic/base3-2.mod",
"andrea-m2/examples/generic/somebits.mod",
"andrea-m2/lib/generic/bitmapope.mod",
"andrea-m2/lib/generic/bitsetfun.mod",
"andrea-m2/lib/generic/largesets.mod",
"andrea-m2/lib/generic/packarray.mod",
"andrea-m2/lib/generic/shufflefa.mod",
"andrea-m2/lib/multiscope/bitmapop.mod",
"andrea-m2/lib/eth-hamburg/blockio.mod",
"andrea-m2/lib/eth-hamburg/cmdline.mod",
"andrea-m2/lib/eth-hamburg/dateopera.mod",
"andrea-m2/lib/eth-hamburg/directacc.mod",
"andrea-m2/lib/eth-hamburg/extendstr.mod",
"andrea-m2/lib/eth-hamburg/foreignco.mod",
"andrea-m2/lib/eth-hamburg/fortrandi.def",
"andrea-m2/lib/eth-hamburg/fortranfo.def",
"andrea-m2/lib/eth-hamburg/fortranjp.def",
"andrea-m2/lib/eth-hamburg/getcharac.mod",
"andrea-m2/lib/eth-hamburg/memorysta.mod",
"andrea-m2/lib/eth-hamburg/moremath.mod",
"andrea-m2/lib/eth-hamburg/realinout.mod",
"andrea-m2/lib/eth-hamburg/simplescr.mod",
"andrea-m2/lib/eth-hamburg/simplewin.mod",
"andrea-m2/lib/eth-hamburg/systemcon.def",
"C.-Lins_Modula-2_Software_Component_Library/Vol4/sorting/timesort.mod",
"PMOS/def/internet.def",
"PMOS/def/kbdriver.def",
"PMOS/def/miscpmos.def",
"PMOS/def/netdb.def",
"PMOS/sources/notdone/fastwind.mod",
"PMOS/sources/general/graphics.mod",
"PMOS/sources/general/lowlevel.def",
"PMOS/sources/general/mouse33.mod",
"PMOS/sources/general/play3.mod",
"PMOS/sources/general/serialmo.mod",
"PMOS/sources/special/lowlevel.mod"]
<>
["examples/Dipl/BUFFERS.MOD",
"examples/Dipl/LIBRARY.MOD",
"examples/Dipl/MACHINE.MOD",
"examples/Dipl/MEMORY.MOD",
"examples/Dipl/NAMES.MOD",
"examples/Dipl/M2/BUFFERS.MOD",
"examples/Dipl/M2/LIBRARY.MOD",
"examples/Dipl/M2/MACHINE.MOD",
"examples/Dipl/M2/MEMORY.MOD",
"examples/Dipl/M2/NAMES.MOD"]
exampleTree :: FilePath -> FilePath -> IO [TestTree]
exampleTree ancestry path =
do let fullPath = combine ancestry path
putStrLn fullPath
isDir <- doesDirectoryExist fullPath
if isDir
then (:[]) . testGroup path . concat <$> (listDirectory fullPath >>= mapM (exampleTree fullPath))
else return . (:[]) . testCase path . unless (any (`isSuffixOf` path) [".BNF", ".bnf", ".GRM"]) $
do moduleSource <- readFile fullPath
(originalModule, prettyModule) <- prettyFile fullPath moduleSource
(originalModule', prettyModule') <- prettyFile fullPath originalModule
(originalModule'', prettyModule'') <- prettyFile fullPath prettyModule
putStrLn fullPath
assertEqual "original=original" originalModule originalModule'
assertEqual "pretty=pretty" prettyModule prettyModule'
assertEqual "pretty=pretty'" prettyModule prettyModule''
assertEqual "original=pretty" originalModule'' prettyModule''
prettyFile :: FilePath -> Text -> IO (Text, Text)
prettyFile path src
| path `elem` unparsables = case (parsedModule1, parsedModule2) of
(Left err1, Left err2)
| err1 == err2 -> putStrLn (unpack $ failureDescription src err1 4) *> pure (src, src)
| otherwise -> putStrLn (unpack $ failureDescription src err1 4 <> failureDescription src err2 4) *> pure (src, src)
_ -> error (path ++ " is supposed to be unparseable")
| otherwise = case parsedModule1 of
Right [tree] -> return (Reserializer.reserialize tree, renderStrict $ layoutPretty defaultLayoutOptions $ pretty tree)
Right trees -> error (show (length trees) ++ " ambiguous parses.")
Left err1 -> case parsedModule2 of
Left err2
| err1 == err2 -> error (unpack $ failureDescription src err1 4)
| otherwise -> error (unpack $ failureDescription src err1 4 <> failureDescription src err2 4)
Right [tree] -> return (Reserializer.reserialize tree, renderStrict $ layoutPretty defaultLayoutOptions $ pretty tree)
Right trees -> error (show (length trees) ++ " ambiguous parses.")
where parsedModule1 = parseAndSimplifyModule Report src
parsedModule2 = parseAndSimplifyModule ISO src
instance {-# overlaps #-} Pretty a => Pretty (Placed a) where
pretty = pretty . snd
instance Pretty (Module Language Language Placed Placed) where
pretty m = pretty ((Identity . snd) Rank2.<$> m)
instance Pretty (Module ISO.Language ISO.Language Placed Placed) where
pretty m = pretty ((Identity . snd) Rank2.<$> m)