diff --git a/eo-phi-normalizer/src/Language/EO/Phi.hs b/eo-phi-normalizer/src/Language/EO/Phi.hs index a849182c2..b824c217e 100644 --- a/eo-phi-normalizer/src/Language/EO/Phi.hs +++ b/eo-phi-normalizer/src/Language/EO/Phi.hs @@ -1,4 +1,5 @@ {-# LANGUAGE LambdaCase #-} + module Language.EO.Phi ( defaultMain, normalize, @@ -8,22 +9,21 @@ module Language.EO.Phi ( module Language.EO.Phi.Syntax.Abs, ) where - import Data.Char (isSpace) import System.Exit (exitFailure) -import qualified Language.EO.Phi.Syntax.Par as Phi -import qualified Language.EO.Phi.Syntax.Print as Phi import Language.EO.Phi.Syntax.Abs import qualified Language.EO.Phi.Syntax.Abs as Phi +import qualified Language.EO.Phi.Syntax.Par as Phi +import qualified Language.EO.Phi.Syntax.Print as Phi import Language.EO.Phi.Normalize -- | Parse a 'Program' or return a parsing error. parseProgram :: String -> Either String Phi.Program parseProgram input = Phi.pProgram tokens - where - tokens = Phi.myLexer input + where + tokens = Phi.myLexer input -- | Parse a 'Program' from a 'String'. -- May throw an 'error` if input has a syntactical or lexical errors. @@ -38,7 +38,7 @@ unsafeParseProgram input = -- then pretty-prints the result to standard output. defaultMain :: IO () defaultMain = do - input <- getContents -- read entire standard input + input <- getContents -- read entire standard input let tokens = Phi.myLexer input case Phi.pProgram tokens of Left parseError -> do @@ -50,7 +50,7 @@ defaultMain = do -- * Overriding generated pretty-printer -- | Like 'Phi.printTree', but without spaces around dots and no indentation for curly braces. -printTree :: Phi.Print a => a -> String +printTree :: (Phi.Print a) => a -> String printTree = shrinkDots . render . Phi.prt 0 -- | Remove spaces around dots. @@ -59,31 +59,34 @@ printTree = shrinkDots . render . Phi.prt 0 -- a ↦ ξ.a shrinkDots :: String -> String shrinkDots [] = [] -shrinkDots (' ':'.':' ':cs) = '.':shrinkDots cs -shrinkDots (c:cs) = c : shrinkDots cs +shrinkDots (' ' : '.' : ' ' : cs) = '.' : shrinkDots cs +shrinkDots (c : cs) = c : shrinkDots cs -- | Copy of 'Phi.render', except no indentation is made for curly braces. render :: Phi.Doc -> String render d = rend 0 False (map ($ "") $ d []) "" - where - rend - :: Int -- ^ Indentation level. - -> Bool -- ^ Pending indentation to be output before next character? - -> [String] - -> ShowS + where + rend :: + Int -> + -- \^ Indentation level. + Bool -> + -- \^ Pending indentation to be output before next character? + [String] -> + ShowS rend i p = \case - "[" :ts -> char '[' . rend i False ts - "(" :ts -> char '(' . rend i False ts - -- "{" :ts -> onNewLine i p . showChar '{' . new (i+1) ts - -- "}" : ";":ts -> onNewLine (i-1) p . showString "};" . new (i-1) ts - -- "}" :ts -> onNewLine (i-1) p . showChar '}' . new (i-1) ts - [";"] -> char ';' - ";" :ts -> char ';' . new i ts - t : ts@(s:_) | closingOrPunctuation s - -> pending . showString t . rend i False ts - t :ts -> pending . space t . rend i False ts - [] -> id - where + "[" : ts -> char '[' . rend i False ts + "(" : ts -> char '(' . rend i False ts + -- "{" :ts -> onNewLine i p . showChar '{' . new (i+1) ts + -- "}" : ";":ts -> onNewLine (i-1) p . showString "};" . new (i-1) ts + -- "}" :ts -> onNewLine (i-1) p . showChar '}' . new (i-1) ts + [";"] -> char ';' + ";" : ts -> char ';' . new i ts + t : ts@(s : _) + | closingOrPunctuation s -> + pending . showString t . rend i False ts + t : ts -> pending . space t . rend i False ts + [] -> id + where -- Output character after pending indentation. char :: Char -> ShowS char c = pending . showChar c @@ -94,7 +97,7 @@ render d = rend 0 False (map ($ "") $ d []) "" -- Indentation (spaces) for given indentation level. indent :: Int -> ShowS - indent i = Phi.replicateS (2*i) (showChar ' ') + indent i = Phi.replicateS (2 * i) (showChar ' ') -- Continue rendering in new line with new indentation. new :: Int -> [String] -> ShowS @@ -104,16 +107,16 @@ render d = rend 0 False (map ($ "") $ d []) "" space :: String -> ShowS space t s = case (all isSpace t, null spc, null rest) of - (True , _ , True ) -> [] -- remove trailing space - (False, _ , True ) -> t -- remove trailing space - (False, True, False) -> t ++ ' ' : s -- add space if none - _ -> t ++ s - where - (spc, rest) = span isSpace s + (True, _, True) -> [] -- remove trailing space + (False, _, True) -> t -- remove trailing space + (False, True, False) -> t ++ ' ' : s -- add space if none + _ -> t ++ s + where + (spc, rest) = span isSpace s closingOrPunctuation :: String -> Bool closingOrPunctuation [c] = c `elem` closerOrPunct - closingOrPunctuation _ = False + closingOrPunctuation _ = False closerOrPunct :: String closerOrPunct = ")],;" diff --git a/eo-phi-normalizer/src/Language/EO/Phi/Normalize.hs b/eo-phi-normalizer/src/Language/EO/Phi/Normalize.hs index ffeb943be..817a409db 100644 --- a/eo-phi-normalizer/src/Language/EO/Phi/Normalize.hs +++ b/eo-phi-normalizer/src/Language/EO/Phi/Normalize.hs @@ -1,13 +1,14 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} + module Language.EO.Phi.Normalize where -import Language.EO.Phi.Syntax.Abs import Data.Maybe (fromMaybe) +import Language.EO.Phi.Syntax.Abs data Context = Context { globalObject :: [Binding] - , thisObject :: [Binding] + , thisObject :: [Binding] } lookupBinding :: Attribute -> [Binding] -> Maybe Object @@ -20,8 +21,9 @@ lookupBinding _ _ = Nothing -- | Normalize an input 𝜑-program. normalize :: Program -> Program normalize (Program bindings) = Program (map (normalizeBindingWith context) bindings) - where - context = Context + where + context = + Context { globalObject = bindings , thisObject = bindings } @@ -47,8 +49,8 @@ peelObject = \case GlobalDispatch attr -> PeeledObject HeadGlobal [ActionDispatch attr] ThisDispatch attr -> PeeledObject HeadThis [ActionDispatch attr] Termination -> PeeledObject HeadTermination [] - where - followedBy (PeeledObject object actions) action = PeeledObject object (actions ++ [action]) + where + followedBy (PeeledObject object actions) action = PeeledObject object (actions ++ [action]) unpeelObject :: PeeledObject -> Object unpeelObject (PeeledObject head_ actions) = @@ -63,8 +65,8 @@ unpeelObject (PeeledObject head_ actions) = ActionDispatch a : as -> go (ThisDispatch a) as _ -> error "impossible: this object without dispatch!" HeadTermination -> go Termination actions - where - go = foldl applyAction - applyAction object = \case - ActionDispatch attr -> ObjectDispatch object attr - ActionApplication bindings -> Application object bindings + where + go = foldl applyAction + applyAction object = \case + ActionDispatch attr -> ObjectDispatch object attr + ActionApplication bindings -> Application object bindings diff --git a/eo-phi-normalizer/src/Language/EO/Phi/Syntax/Abs.hs b/eo-phi-normalizer/src/Language/EO/Phi/Syntax/Abs.hs index ae634d48b..4ae129573 100644 --- a/eo-phi-normalizer/src/Language/EO/Phi/Syntax/Abs.hs +++ b/eo-phi-normalizer/src/Language/EO/Phi/Syntax/Abs.hs @@ -1,52 +1,59 @@ -- File generated by the BNF Converter (bnfc 2.9.5). - {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | The abstract syntax of language Syntax. - module Language.EO.Phi.Syntax.Abs where -import Prelude (String) -import qualified Prelude as C (Eq, Ord, Show, Read) import qualified Data.String +import Prelude (String) +import qualified Prelude as C (Eq, Ord, Read, Show) -import qualified Data.Data as C (Data, Typeable) +import qualified Data.Data as C (Data, Typeable) import qualified GHC.Generics as C (Generic) data Program = Program [Binding] deriving (C.Eq, C.Ord, C.Show, C.Read, C.Data, C.Typeable, C.Generic) data Object - = Formation [Binding] - | Application Object [Binding] - | ObjectDispatch Object Attribute - | GlobalDispatch Attribute - | ThisDispatch Attribute - | Termination + = Formation [Binding] + | Application Object [Binding] + | ObjectDispatch Object Attribute + | GlobalDispatch Attribute + | ThisDispatch Attribute + | Termination deriving (C.Eq, C.Ord, C.Show, C.Read, C.Data, C.Typeable, C.Generic) data Binding - = AlphaBinding Attribute Object - | EmptyBinding Attribute - | DeltaBinding Bytes - | LambdaBinding Function + = AlphaBinding Attribute Object + | EmptyBinding Attribute + | DeltaBinding Bytes + | LambdaBinding Function deriving (C.Eq, C.Ord, C.Show, C.Read, C.Data, C.Typeable, C.Generic) data Attribute - = Phi | Rho | Sigma | VTX | Label LabelId | Alpha AlphaIndex + = Phi + | Rho + | Sigma + | VTX + | Label LabelId + | Alpha AlphaIndex deriving (C.Eq, C.Ord, C.Show, C.Read, C.Data, C.Typeable, C.Generic) data PeeledObject = PeeledObject ObjectHead [ObjectAction] deriving (C.Eq, C.Ord, C.Show, C.Read, C.Data, C.Typeable, C.Generic) data ObjectHead - = HeadFormation [Binding] | HeadGlobal | HeadThis | HeadTermination + = HeadFormation [Binding] + | HeadGlobal + | HeadThis + | HeadTermination deriving (C.Eq, C.Ord, C.Show, C.Read, C.Data, C.Typeable, C.Generic) data ObjectAction - = ActionApplication [Binding] | ActionDispatch Attribute + = ActionApplication [Binding] + | ActionDispatch Attribute deriving (C.Eq, C.Ord, C.Show, C.Read, C.Data, C.Typeable, C.Generic) newtype Bytes = Bytes String @@ -60,4 +67,3 @@ newtype LabelId = LabelId String newtype AlphaIndex = AlphaIndex String deriving (C.Eq, C.Ord, C.Show, C.Read, C.Data, C.Typeable, C.Generic, Data.String.IsString) - diff --git a/eo-phi-normalizer/src/Language/EO/Phi/Syntax/Print.hs b/eo-phi-normalizer/src/Language/EO/Phi/Syntax/Print.hs index 9156fd24e..835a64076 100644 --- a/eo-phi-normalizer/src/Language/EO/Phi/Syntax/Print.hs +++ b/eo-phi-normalizer/src/Language/EO/Phi/Syntax/Print.hs @@ -1,5 +1,4 @@ -- File generated by the BNF Converter (bnfc 2.9.5). - {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} @@ -8,23 +7,40 @@ #endif -- | Pretty-printer for Language. - module Language.EO.Phi.Syntax.Print where -import Prelude - ( ($), (.) - , Bool(..), (==), (<) - , Int, Integer, Double, (+), (-), (*) - , String, (++) - , ShowS, showChar, showString - , all, elem, foldr, id, map, null, replicate, shows, span - ) -import Data.Char ( Char, isSpace ) +import Data.Char (Char, isSpace) import qualified Language.EO.Phi.Syntax.Abs +import Prelude ( + Bool (..), + Double, + Int, + Integer, + ShowS, + String, + all, + elem, + foldr, + id, + map, + null, + replicate, + showChar, + showString, + shows, + span, + ($), + (*), + (+), + (++), + (-), + (.), + (<), + (==), + ) -- | The top-level printing method. - -printTree :: Print a => a -> String +printTree :: (Print a) => a -> String printTree = render . prt 0 type Doc = [ShowS] -> [ShowS] @@ -34,25 +50,28 @@ doc = (:) render :: Doc -> String render d = rend 0 False (map ($ "") $ d []) "" - where - rend - :: Int -- ^ Indentation level. - -> Bool -- ^ Pending indentation to be output before next character? - -> [String] - -> ShowS + where + rend :: + Int -> + -- \^ Indentation level. + Bool -> + -- \^ Pending indentation to be output before next character? + [String] -> + ShowS rend i p = \case - "[" :ts -> char '[' . rend i False ts - "(" :ts -> char '(' . rend i False ts - "{" :ts -> onNewLine i p . showChar '{' . new (i+1) ts - "}" : ";":ts -> onNewLine (i-1) p . showString "};" . new (i-1) ts - "}" :ts -> onNewLine (i-1) p . showChar '}' . new (i-1) ts - [";"] -> char ';' - ";" :ts -> char ';' . new i ts - t : ts@(s:_) | closingOrPunctuation s - -> pending . showString t . rend i False ts - t :ts -> pending . space t . rend i False ts - [] -> id - where + "[" : ts -> char '[' . rend i False ts + "(" : ts -> char '(' . rend i False ts + "{" : ts -> onNewLine i p . showChar '{' . new (i + 1) ts + "}" : ";" : ts -> onNewLine (i - 1) p . showString "};" . new (i - 1) ts + "}" : ts -> onNewLine (i - 1) p . showChar '}' . new (i - 1) ts + [";"] -> char ';' + ";" : ts -> char ';' . new i ts + t : ts@(s : _) + | closingOrPunctuation s -> + pending . showString t . rend i False ts + t : ts -> pending . space t . rend i False ts + [] -> id + where -- Output character after pending indentation. char :: Char -> ShowS char c = pending . showChar c @@ -63,7 +82,7 @@ render d = rend 0 False (map ($ "") $ d []) "" -- Indentation (spaces) for given indentation level. indent :: Int -> ShowS - indent i = replicateS (2*i) (showChar ' ') + indent i = replicateS (2 * i) (showChar ' ') -- Continue rendering in new line with new indentation. new :: Int -> [String] -> ShowS @@ -77,16 +96,16 @@ render d = rend 0 False (map ($ "") $ d []) "" space :: String -> ShowS space t s = case (all isSpace t, null spc, null rest) of - (True , _ , True ) -> [] -- remove trailing space - (False, _ , True ) -> t -- remove trailing space - (False, True, False) -> t ++ ' ' : s -- add space if none - _ -> t ++ s - where - (spc, rest) = span isSpace s + (True, _, True) -> [] -- remove trailing space + (False, _, True) -> t -- remove trailing space + (False, True, False) -> t ++ ' ' : s -- add space if none + _ -> t ++ s + where + (spc, rest) = span isSpace s closingOrPunctuation :: String -> Bool closingOrPunctuation [c] = c `elem` closerOrPunct - closingOrPunctuation _ = False + closingOrPunctuation _ = False closerOrPunct :: String closerOrPunct = ")],;" @@ -104,11 +123,10 @@ replicateS :: Int -> ShowS -> ShowS replicateS n f = concatS (replicate n f) -- | The printer class does the job. - class Print a where prt :: Int -> a -> Doc -instance {-# OVERLAPPABLE #-} Print a => Print [a] where +instance {-# OVERLAPPABLE #-} (Print a) => Print [a] where prt i = concatD . map (prt i) instance Print Char where @@ -168,7 +186,7 @@ instance Print Language.EO.Phi.Syntax.Abs.Binding where instance Print [Language.EO.Phi.Syntax.Abs.Binding] where prt _ [] = concatD [] prt _ [x] = concatD [prt 0 x] - prt _ (x:xs) = concatD [prt 0 x, doc (showString ","), prt 0 xs] + prt _ (x : xs) = concatD [prt 0 x, doc (showString ","), prt 0 xs] instance Print Language.EO.Phi.Syntax.Abs.Attribute where prt i = \case @@ -197,4 +215,4 @@ instance Print Language.EO.Phi.Syntax.Abs.ObjectAction where instance Print [Language.EO.Phi.Syntax.Abs.ObjectAction] where prt _ [] = concatD [] - prt _ (x:xs) = concatD [prt 0 x, prt 0 xs] + prt _ (x : xs) = concatD [prt 0 x, prt 0 xs] diff --git a/eo-phi-normalizer/test/Language/EO/PhiSpec.hs b/eo-phi-normalizer/test/Language/EO/PhiSpec.hs index 32516b737..195d02d05 100644 --- a/eo-phi-normalizer/test/Language/EO/PhiSpec.hs +++ b/eo-phi-normalizer/test/Language/EO/PhiSpec.hs @@ -1,10 +1,11 @@ {-# LANGUAGE RecordWildCards #-} + module Language.EO.PhiSpec where -import Test.Hspec import Control.Monad (forM_) -import Data.List (dropWhileEnd) import Data.Char (isSpace) +import Data.List (dropWhileEnd) +import Test.Hspec import qualified Language.EO.Phi as Phi import Test.EO.Phi diff --git a/eo-phi-normalizer/test/Test/EO/Phi.hs b/eo-phi-normalizer/test/Test/EO/Phi.hs index 0fa874462..b4f9f16ff 100644 --- a/eo-phi-normalizer/test/Test/EO/Phi.hs +++ b/eo-phi-normalizer/test/Test/EO/Phi.hs @@ -1,26 +1,28 @@ -{-# OPTIONS_GHC -Wno-orphans #-} {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + module Test.EO.Phi where -import Data.Aeson (FromJSON(..)) +import Control.Monad (forM) +import Data.Aeson (FromJSON (..)) import qualified Data.Yaml as Yaml +import GHC.Generics (Generic) import System.Directory (listDirectory) import System.FilePath (()) -import GHC.Generics (Generic) -import Control.Monad (forM) -import qualified Language.EO.Phi as Phi -import Language.EO.Phi (unsafeParseProgram) import Data.List (sort) +import Language.EO.Phi (unsafeParseProgram) +import qualified Language.EO.Phi as Phi data PhiTest = PhiTest - { name :: String - , input :: Phi.Program + { name :: String + , input :: Phi.Program , normalized :: Phi.Program , prettified :: String - } deriving (Generic, FromJSON) + } + deriving (Generic, FromJSON) allPhiTests :: FilePath -> IO [PhiTest] allPhiTests dir = do