Add all files

.ghci

@@ -0,0 +1,2 @@
+:set -XFlexibleContexts
+:set -XPartialTypeSignatures

.gitignore

@@ -0,0 +1,22 @@
+# https://github.com/github/gitignore/blob/master/Haskell.gitignore
+dist
+dist-*
+cabal-dev
+*.o
+*.hi
+*.chi
+*.chs.h
+*.dyn_o
+*.dyn_hi
+.hpc
+.hsenv
+.cabal-sandbox/
+cabal.sandbox.config
+*.prof
+*.aux
+*.hp
+*.eventlog
+.stack-work/
+cabal.project.local
+.HTF/
+.ghc.environment.*

LICENSE

@@ -0,0 +1,30 @@
+Copyright Author name here (c) 2017
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Author name here nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

README.md

@@ -0,0 +1 @@
+# lihsp

Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

app/Main.hs

@@ -0,0 +1,6 @@
+module Main
+  ( main
+  ) where
+
+main :: IO ()
+main = putStrLn "COMPILED!"

lihsp.cabal

@@ -0,0 +1,66 @@
+-- This file has been generated from package.yaml by hpack version 0.17.0.
+--
+-- see: https://github.com/sol/hpack
+
+name:           lihsp
+version:        0.1.0.0
+category:       Web
+homepage:       https://github.com/githubuser/lihsp#readme
+bug-reports:    https://github.com/githubuser/lihsp/issues
+author:         Author name here
+maintainer:     [email protected]
+copyright:      2017 Author name here
+license:        BSD3
+license-file:   LICENSE
+build-type:     Simple
+cabal-version:  >= 1.10
+
+extra-source-files:
+    README.md
+
+source-repository head
+  type: git
+  location: https://github.com/githubuser/lihsp
+
+library
+  hs-source-dirs:
+      src
+  ghc-options: -Wall -Werror -Wmissing-import-lists -Wincomplete-record-updates -Wincomplete-uni-patterns
+  build-depends:
+      base >=4.7 && <5
+    , lens
+    , mtl
+    , parsec
+  exposed-modules:
+      Lihsp.AST
+      Lihsp.Error
+      Lihsp.IO
+      Lihsp.Normalize
+      Lihsp.Parse
+      Lihsp.Transpile
+      Lihsp.Utils
+  default-language: Haskell2010
+
+executable lihsp-exe
+  main-is: Main.hs
+  hs-source-dirs:
+      app
+  ghc-options: -Wall -Werror -Wmissing-import-lists -Wincomplete-record-updates -Wincomplete-uni-patterns -threaded -rtsopts -with-rtsopts=-N
+  build-depends:
+      base >=4.7 && <5
+    , lens
+    , mtl
+    , lihsp
+  default-language: Haskell2010
+
+test-suite lihsp-test
+  type: exitcode-stdio-1.0
+  main-is: Spec.hs
+  hs-source-dirs:
+      test
+  ghc-options: -Wall -Werror -Wmissing-import-lists -Wincomplete-record-updates -Wincomplete-uni-patterns -threaded -rtsopts -with-rtsopts=-N
+  build-depends:
+      base >=4.7 && <5
+    , lens
+    , mtl
+  default-language: Haskell2010

package.yaml

@@ -0,0 +1,43 @@
+name: lihsp
+version: '0.1.0.0'
+category: Web
+author: Author name here
+maintainer: [email protected]
+copyright: 2017 Author name here
+license: BSD3
+github: githubuser/lihsp
+extra-source-files:
+- README.md
+ghc-options:
+- -Wall
+- -Werror
+- -Wmissing-import-lists
+- -Wincomplete-record-updates
+- -Wincomplete-uni-patterns
+dependencies:
+- base >=4.7 && <5
+- lens
+- mtl
+library:
+  source-dirs: src
+  exposed-modules:
+  dependencies:
+  - parsec
+executables:
+  lihsp-exe:
+    main: Main.hs
+    source-dirs: app
+    ghc-options:
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N
+    dependencies:
+    - lihsp
+tests:
+  lihsp-test:
+    main: Spec.hs
+    source-dirs: test
+    ghc-options:
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N

src/Lihsp/AST.hs

@@ -0,0 +1,196 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+{-
+* Macros
+ Macros edit the parse tree, which the compiler converts to an AST which is transpiled into Eta.
+ 1) Top-level macros are run, with the code forms represented as a lists of parse expressions (lists, symbols, and literals).
+    The output of the macro programs is rendered as a list and inserted into the file.
+ 2) Repeat step 1 until no more macros are available.
+-}
+module Lihsp.AST where
+
+import Control.Lens.Operators ((^.))
+import Control.Lens.TH (makeFieldsNoPrefix)
+
+import Data.Semigroup ((<>))
+
+import Lihsp.Utils
+       (Bracket(Parentheses, SingleQuotes, SquareBrackets),
+        Delimiter(Commas, Pipes), delimit, renderBlock, surround)
+
+type Identifier = String
+
+data FunctionApplication = FunctionApplication
+  { _function :: Expression
+  , _arguments :: [Expression]
+  }
+
+data DataDeclaration = DataDeclaration
+  { _typeDefinition :: FunctionApplication
+  , _constructors :: [FunctionApplication]
+  }
+
+newtype ArgumentList =
+  ArgumentList [Expression]
+
+instance Show ArgumentList where
+  show :: ArgumentList -> String
+  show (ArgumentList arguments) = concatMap show arguments
+
+newtype FunctionDefinition =
+  FunctionDefinition (Identifier, [(ArgumentList, Expression)])
+
+instance Show FunctionDefinition where
+  show :: FunctionDefinition -> String
+  show (FunctionDefinition (name, cases)) = renderBlock $ map showCase cases
+    where
+      showCase (pattern', body) = show name <> show pattern' <> show body
+
+newtype ImportList =
+  ImportList [Identifier]
+
+instance Show ImportList where
+  show :: ImportList -> String
+  show (ImportList importList) =
+    surround Parentheses $ delimit Commas $ map show importList
+
+data LetBlock = LetBlock
+  { _bindings :: [(Identifier, Expression)]
+  , _body :: Expression
+  }
+
+data QualifiedImport = QualifiedImport
+  { _moduleName :: Identifier
+  , _alias :: Identifier
+  , _imports :: ImportList
+  }
+
+data RestrictedImport = RestrictedImport
+  { _moduleName :: Identifier
+  , _imports :: ImportList
+  }
+
+data TypeclassInstance = TypeclassInstance
+  { _moduleName :: Expression
+  , _definitions :: [FunctionDefinition]
+  }
+
+data TypeSynonym = TypeSynonym
+  { _alias :: Expression
+  , _definition :: Expression
+  }
+
+data Expression
+  = EFunctionApplication FunctionApplication
+  | EIdentifier Identifier
+  | ELetBlock LetBlock
+  | ELiteral Literal
+
+instance Show Expression where
+  show :: Expression -> String
+  show (EFunctionApplication x) = show x
+  show (EIdentifier x) = surround Parentheses x
+  show (ELetBlock x) = show x
+  show (ELiteral x) = surround Parentheses $ show x
+
+data Literal
+  = LChar Char
+  | LInt Int
+  | LList [Expression]
+
+instance Show Literal where
+  show :: Literal -> String
+  show (LInt int) = show int
+  show (LChar char) = surround SingleQuotes [char]
+  show (LList list) = surround SquareBrackets $ delimit Commas (map show list)
+
+data Statement
+  = SDataDeclaration DataDeclaration
+  | SFunctionDefinition FunctionDefinition
+  | SModuleDeclaration Identifier
+  | SQualifiedImport QualifiedImport
+  | SRestrictedImport RestrictedImport
+  | STypeclassInstance TypeclassInstance
+  | STypeSynonym TypeSynonym
+  | SUnrestrictedImport Identifier
+
+instance Show Statement where
+  show :: Statement -> String
+  show (SDataDeclaration x) = show x
+  show (SFunctionDefinition x) = show x
+  show (SModuleDeclaration x) = show x
+  show (SQualifiedImport x) = show x
+  show (SRestrictedImport x) = show x
+  show (STypeclassInstance x) = show x
+  show (STypeSynonym x) = show x
+  show (SUnrestrictedImport x) = show x
+
+type Program = [Statement]
+
+makeFieldsNoPrefix ''DataDeclaration
+
+makeFieldsNoPrefix ''FunctionApplication
+
+makeFieldsNoPrefix ''FunctionDefinition
+
+makeFieldsNoPrefix ''LetBlock
+
+makeFieldsNoPrefix ''QualifiedImport
+
+makeFieldsNoPrefix ''RestrictedImport
+
+makeFieldsNoPrefix ''TypeclassInstance
+
+makeFieldsNoPrefix ''TypeSynonym
+
+instance Show FunctionApplication where
+  show :: FunctionApplication -> String
+  show functionApplication =
+    surround Parentheses $
+    show (functionApplication ^. function) <>
+    concatMap show (functionApplication ^. arguments)
+
+instance Show DataDeclaration where
+  show :: DataDeclaration -> String
+  show dataDeclaration =
+    "data " <> show (dataDeclaration ^. typeDefinition) <> "=" <>
+    delimit Pipes (map show $ dataDeclaration ^. constructors)
+
+instance Show LetBlock where
+  show :: LetBlock -> String
+  show letBlock =
+    "let " <> renderBlock (map showBinding (letBlock ^. bindings)) <> "in" <>
+    show (letBlock ^. body)
+    where
+      showBinding (identifier, value) = identifier <> "=" <> show value
+
+instance Show QualifiedImport where
+  show :: QualifiedImport -> String
+  show qualifiedImport =
+    "import " <> qualifiedImport ^. moduleName <> " as " <> qualifiedImport ^.
+    alias <>
+    show (qualifiedImport ^. imports)
+
+instance Show RestrictedImport where
+  show :: RestrictedImport -> String
+  show restrictedImport =
+    "import " <> restrictedImport ^. moduleName <>
+    show (restrictedImport ^. imports)
+
+instance Show TypeclassInstance where
+  show :: TypeclassInstance -> String
+  show typeclassInstance =
+    "instance" <> show (typeclassInstance ^. moduleName) <> "where" <>
+    renderBlock (map show $ typeclassInstance ^. definitions)
+
+instance Show TypeSynonym where
+  show :: TypeSynonym -> String
+  show typeSynonym =
+    "type" <> show (typeSynonym ^. alias) <> "=" <>
+    show (typeSynonym ^. definition)

src/Lihsp/Error.hs

@@ -0,0 +1,8 @@
+module Lihsp.Error where
+
+import Text.Parsec (ParseError)
+
+data Error
+  = NormalizeError String
+  | ParseError ParseError
+  deriving (Show)

src/Lihsp/IO.hs

@@ -0,0 +1,11 @@
+module Lihsp.IO where
+
+import Data.Semigroup ((<>))
+
+import Lihsp.Transpile (transpile)
+
+transpileFile :: FilePath -> IO ()
+transpileFile path = do
+  contents <- readFile $ path <> ".lihsp"
+  let newContents = transpile contents
+  either print (writeFile $ path <> ".hs") newContents