├── .github └── workflows │ └── haskell-ci.yml ├── .gitignore ├── LICENSE ├── README.md ├── Setup.hs ├── cabal.project.dist ├── golang.cabal ├── src └── Language │ └── Go │ ├── AST.hs │ ├── Desugar.hs │ ├── Parser.hs │ ├── Rec.hs │ ├── Rename.hs │ └── Types.hs └── stack.yaml /.github/workflows/haskell-ci.yml: -------------------------------------------------------------------------------- 1 | # This GitHub workflow config has been generated by a script via 2 | # 3 | # haskell-ci 'github' 'golang.cabal' 4 | # 5 | # To regenerate the script (for example after adjusting tested-with) run 6 | # 7 | # haskell-ci regenerate 8 | # 9 | # For more information, see https://github.com/haskell-CI/haskell-ci 10 | # 11 | # version: 0.16.3 12 | # 13 | # REGENDATA ("0.16.3",["github","golang.cabal"]) 14 | # 15 | name: Haskell-CI 16 | on: 17 | - push 18 | - pull_request 19 | jobs: 20 | linux: 21 | name: Haskell-CI - Linux - ${{ matrix.compiler }} 22 | runs-on: ubuntu-20.04 23 | timeout-minutes: 24 | 60 25 | container: 26 | image: buildpack-deps:bionic 27 | continue-on-error: ${{ matrix.allow-failure }} 28 | strategy: 29 | matrix: 30 | include: 31 | - compiler: ghc-9.6.2 32 | compilerKind: ghc 33 | compilerVersion: 9.6.2 34 | setup-method: ghcup 35 | allow-failure: false 36 | - compiler: ghc-9.4.5 37 | compilerKind: ghc 38 | compilerVersion: 9.4.5 39 | setup-method: ghcup 40 | allow-failure: false 41 | - compiler: ghc-9.2.7 42 | compilerKind: ghc 43 | compilerVersion: 9.2.7 44 | setup-method: ghcup 45 | allow-failure: false 46 | - compiler: ghc-9.0.2 47 | compilerKind: ghc 48 | compilerVersion: 9.0.2 49 | setup-method: ghcup 50 | allow-failure: false 51 | - compiler: ghc-8.10.7 52 | compilerKind: ghc 53 | compilerVersion: 8.10.7 54 | setup-method: ghcup 55 | allow-failure: false 56 | - compiler: ghc-8.8.4 57 | compilerKind: ghc 58 | compilerVersion: 8.8.4 59 | setup-method: hvr-ppa 60 | allow-failure: false 61 | - compiler: ghc-8.6.5 62 | compilerKind: ghc 63 | compilerVersion: 8.6.5 64 | setup-method: hvr-ppa 65 | allow-failure: false 66 | fail-fast: false 67 | steps: 68 | - name: apt 69 | run: | 70 | apt-get update 71 | apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 72 | if [ "${{ matrix.setup-method }}" = ghcup ]; then 73 | mkdir -p "$HOME/.ghcup/bin" 74 | curl -sL https://downloads.haskell.org/ghcup/0.1.19.2/x86_64-linux-ghcup-0.1.19.2 > "$HOME/.ghcup/bin/ghcup" 75 | chmod a+x "$HOME/.ghcup/bin/ghcup" 76 | "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) 77 | "$HOME/.ghcup/bin/ghcup" install cabal 3.10.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false) 78 | else 79 | apt-add-repository -y 'ppa:hvr/ghc' 80 | apt-get update 81 | apt-get install -y "$HCNAME" 82 | mkdir -p "$HOME/.ghcup/bin" 83 | curl -sL https://downloads.haskell.org/ghcup/0.1.19.2/x86_64-linux-ghcup-0.1.19.2 > "$HOME/.ghcup/bin/ghcup" 84 | chmod a+x "$HOME/.ghcup/bin/ghcup" 85 | "$HOME/.ghcup/bin/ghcup" install cabal 3.10.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false) 86 | fi 87 | env: 88 | HCKIND: ${{ matrix.compilerKind }} 89 | HCNAME: ${{ matrix.compiler }} 90 | HCVER: ${{ matrix.compilerVersion }} 91 | - name: Set PATH and environment variables 92 | run: | 93 | echo "$HOME/.cabal/bin" >> $GITHUB_PATH 94 | echo "LANG=C.UTF-8" >> "$GITHUB_ENV" 95 | echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" 96 | echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" 97 | HCDIR=/opt/$HCKIND/$HCVER 98 | if [ "${{ matrix.setup-method }}" = ghcup ]; then 99 | HC=$HOME/.ghcup/bin/$HCKIND-$HCVER 100 | echo "HC=$HC" >> "$GITHUB_ENV" 101 | echo "HCPKG=$HOME/.ghcup/bin/$HCKIND-pkg-$HCVER" >> "$GITHUB_ENV" 102 | echo "HADDOCK=$HOME/.ghcup/bin/haddock-$HCVER" >> "$GITHUB_ENV" 103 | echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.1.0 -vnormal+nowrap" >> "$GITHUB_ENV" 104 | else 105 | HC=$HCDIR/bin/$HCKIND 106 | echo "HC=$HC" >> "$GITHUB_ENV" 107 | echo "HCPKG=$HCDIR/bin/$HCKIND-pkg" >> "$GITHUB_ENV" 108 | echo "HADDOCK=$HCDIR/bin/haddock" >> "$GITHUB_ENV" 109 | echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.1.0 -vnormal+nowrap" >> "$GITHUB_ENV" 110 | fi 111 | 112 | HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') 113 | echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" 114 | echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" 115 | echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" 116 | echo "HEADHACKAGE=false" >> "$GITHUB_ENV" 117 | echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" 118 | echo "GHCJSARITH=0" >> "$GITHUB_ENV" 119 | env: 120 | HCKIND: ${{ matrix.compilerKind }} 121 | HCNAME: ${{ matrix.compiler }} 122 | HCVER: ${{ matrix.compilerVersion }} 123 | - name: env 124 | run: | 125 | env 126 | - name: write cabal config 127 | run: | 128 | mkdir -p $CABAL_DIR 129 | cat >> $CABAL_CONFIG <> $CABAL_CONFIG < cabal-plan.xz 162 | echo 'f62ccb2971567a5f638f2005ad3173dba14693a45154c1508645c52289714cb2 cabal-plan.xz' | sha256sum -c - 163 | xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan 164 | rm -f cabal-plan.xz 165 | chmod a+x $HOME/.cabal/bin/cabal-plan 166 | cabal-plan --version 167 | - name: checkout 168 | uses: actions/checkout@v3 169 | with: 170 | path: source 171 | - name: initial cabal.project for sdist 172 | run: | 173 | touch cabal.project 174 | echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project 175 | cat cabal.project 176 | - name: sdist 177 | run: | 178 | mkdir -p sdist 179 | $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist 180 | - name: unpack 181 | run: | 182 | mkdir -p unpacked 183 | find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; 184 | - name: generate cabal.project 185 | run: | 186 | PKGDIR_golang="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/golang-[0-9.]*')" 187 | echo "PKGDIR_golang=${PKGDIR_golang}" >> "$GITHUB_ENV" 188 | rm -f cabal.project cabal.project.local 189 | touch cabal.project 190 | touch cabal.project.local 191 | echo "packages: ${PKGDIR_golang}" >> cabal.project 192 | echo "package golang" >> cabal.project 193 | echo " ghc-options: -Werror=missing-methods" >> cabal.project 194 | cat >> cabal.project <> cabal.project.local 197 | cat cabal.project 198 | cat cabal.project.local 199 | - name: dump install plan 200 | run: | 201 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all 202 | cabal-plan 203 | - name: restore cache 204 | uses: actions/cache/restore@v3 205 | with: 206 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 207 | path: ~/.cabal/store 208 | restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- 209 | - name: install dependencies 210 | run: | 211 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all 212 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all 213 | - name: build w/o tests 214 | run: | 215 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 216 | - name: build 217 | run: | 218 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always 219 | - name: cabal check 220 | run: | 221 | cd ${PKGDIR_golang} || false 222 | ${CABAL} -vnormal check 223 | - name: haddock 224 | run: | 225 | $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all 226 | - name: unconstrained build 227 | run: | 228 | rm -f cabal.project.local 229 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 230 | - name: save cache 231 | uses: actions/cache/save@v3 232 | if: always() 233 | with: 234 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 235 | path: ~/.cabal/store 236 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work 2 | dist/ 3 | dist-newstyle/ 4 | /cabal.project 5 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016-2017, Galois Inc. 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the names of Galois Inc nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Golang 2 | ====== 3 | 4 | This is a parser frontend for the Go programming language designed to be used with [goblin](https://github.com/galoisinc/goblin). 5 | 6 | The abstract syntax and type definitions are in [AST.hs](https://github.com/GaloisInc/golang/blob/master/src/Language/Go/AST.hs) and [Types.hs](https://github.com/GaloisInc/golang/blob/master/src/Language/Go/Types.hs), respectively. [Rec.hs](https://github.com/GaloisInc/golang/blob/master/src/Language/Go/Rec.hs) contains generic combinators for folding over the syntax. 7 | 8 | The frontend proceeds in three phases: 9 | 1) The JSON parser ([Parser.hs](https://github.com/GaloisInc/golang/blob/master/src/Language/Go/Parser.hs)) deserializes a JSON-encoded AST produced by goblin. 10 | 2) The desugaring pass ([Desugar.hs](https://github.com/GaloisInc/golang/blob/master/src/Language/Go/Desugar.hs)) performs various (purely syntactic) transformations. 11 | 3) The renamer ([Renamer.hs](https://github.com/GaloisInc/golang/blob/master/src/Language/Go/Renamer.hs)) fills in missing qualifiers so that all global identifiers become fully qualified. 12 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /cabal.project.dist: -------------------------------------------------------------------------------- 1 | packages: . 2 | -------------------------------------------------------------------------------- /golang.cabal: -------------------------------------------------------------------------------- 1 | name: golang 2 | version: 0.1.0.0 3 | synopsis: A parser frontend for Go designed to be used with goblin. 4 | description: 5 | This is a parser frontend for the Go programming language designed to be used 6 | with goblin. 7 | 8 | The abstract syntax and type definitions are in AST.hs and Types.hs, 9 | respectively. Rec.hs contains generic combinators for folding over the syntax. 10 | 11 | The frontend proceeds in three phases: 12 | 13 | * The JSON parser (Parser.hs) deserializes a JSON-encoded AST produced by 14 | goblin. 15 | * The desugaring pass (Desugar.hs) performs various (purely syntactic) 16 | transformations. 17 | * The renamer (Renamer.hs) fills in missing qualifiers so that all global 18 | identifiers become fully qualified. 19 | license: BSD3 20 | license-file: LICENSE 21 | author: Alex Bagnall 22 | maintainer: Alex Bagnall , Tristan Ravitch 23 | copyright: (c) 2020-2021 Galois Inc. 24 | tested-with: GHC==8.6.5, GHC==8.8.4, GHC==8.10.7, GHC==9.0.2, GHC==9.2.7, GHC==9.4.5, GHC==9.6.2 25 | homepage: https://github.com/GaloisInc/golang 26 | bug-reports: https://github.com/GaloisInc/golang/issues 27 | category: Language 28 | build-type: Simple 29 | cabal-version: >=1.10 30 | 31 | Source-repository head 32 | type: git 33 | location: git://github.com/GaloisInc/golang 34 | 35 | Source-repository this 36 | type: git 37 | location: git://github.com/GaloisInc/golang 38 | tag: 0.1.0.0 39 | 40 | library 41 | exposed-modules: Language.Go.AST 42 | Language.Go.Desugar 43 | Language.Go.Parser 44 | Language.Go.Rec 45 | Language.Go.Rename 46 | Language.Go.Types 47 | other-modules: 48 | build-depends: base >= 4.9 && < 5 49 | , mtl 50 | , text >= 1.2 51 | , aeson 52 | , bytestring 53 | , vector 54 | , unordered-containers 55 | , parameterized-utils 56 | , data-default-class 57 | hs-source-dirs: src 58 | ghc-options: -Wall -fno-warn-orphans -Wno-unticked-promoted-constructors 59 | default-language: Haskell2010 60 | Build-tools: 61 | -------------------------------------------------------------------------------- /src/Language/Go/AST.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Language.Go.AST 3 | Description : Go language abstract syntax 4 | Maintainer : abagnall@galois.com 5 | Stability : experimental 6 | 7 | Go syntax in open recursion style, similar to the 'App' type of 8 | crucible expressions. 9 | 10 | The constructors are designed to closely match the standard 'go/ast' 11 | type definitions, with some adjustments to account for liberties taken 12 | by goblin as well as additional "internal language" forms such as 13 | tuples. 14 | 15 | We also include semantic type information in expression nodes, and 16 | have a BasicConstExpr form for representing the results of evaluated 17 | constant expressions (most literals end up as BasicConstExprs). 18 | -} 19 | {-# LANGUAGE DataKinds #-} 20 | {-# LANGUAGE DeriveFunctor #-} 21 | {-# LANGUAGE FlexibleInstances #-} 22 | {-# LANGUAGE GADTs #-} 23 | {-# LANGUAGE KindSignatures #-} 24 | {-# LANGUAGE OverloadedStrings #-} 25 | {-# LANGUAGE PolyKinds #-} 26 | {-# LANGUAGE QuantifiedConstraints #-} 27 | {-# LANGUAGE RankNTypes #-} 28 | {-# LANGUAGE StandaloneDeriving #-} 29 | module Language.Go.AST where 30 | 31 | import qualified Data.Kind as Kind 32 | import Data.Text hiding (inits, replicate) 33 | 34 | import Data.Parameterized.TraversableFC 35 | 36 | import Language.Go.Rec 37 | import Language.Go.Types 38 | 39 | -- TODO: make fields strict? 40 | 41 | -- | The type of AST nodes with annotations of type 'a' is the least 42 | -- fixed point of 'NodeF a'. 43 | type Node a = Fix (NodeF a) 44 | 45 | -- | Go AST node functor indexed by NodeType. 46 | data NodeF (a :: Kind.Type) (f :: NodeType -> Kind.Type) (i :: NodeType) where 47 | 48 | -- | The main package. 49 | MainNode :: Text -- ^ main package name 50 | -> f Package -- ^ the main package itself 51 | -> [f Package] -- ^ flat list containing the transitive 52 | -- closure of dependencies, ordered such 53 | -- that if package A depends on B, then B 54 | -- appears before A in the list (guaranteed 55 | -- by goblin). 56 | -> NodeF a f Main 57 | 58 | -- | A package contains one or more files. 59 | PackageNode :: Text -- ^ package name 60 | -> Text -- ^ package path 61 | -> [Text] -- ^ paths of imports 62 | -> [Text] -- ^ source file absolute paths 63 | -> [f File] -- ^ source files 64 | -> [f Stmt] -- ^ initializers in execution order 65 | -> NodeF a f Package 66 | 67 | -- | A Go source file. 68 | FileNode :: Text -- ^ file path 69 | -> Ident -- ^ package name 70 | -> [f Decl] -- ^ top-level declarations 71 | -> [f Decl] -- ^ imports in this file 72 | -> NodeF a f File 73 | 74 | ---------------------------------------------------------------------- 75 | -- Statements 76 | 77 | -- | An assignment or a short variable declaration. 78 | AssignStmt :: a 79 | -> AssignType 80 | -> Maybe BinaryOp 81 | -> [f Expr] -- ^ lhs 82 | -> [f Expr] -- ^ rhs 83 | -> NodeF a f Stmt 84 | 85 | BlockStmt :: a 86 | -> f Block 87 | -> NodeF a f Stmt 88 | 89 | -- | A break, continue, goto, or fallthrough statement. 90 | BranchStmt :: a 91 | -> BranchType 92 | -> Maybe Ident -- ^ label 93 | -> NodeF a f Stmt 94 | 95 | -- | A declaration in a statement list. 96 | DeclStmt :: a 97 | -> f Decl 98 | -> NodeF a f Stmt 99 | 100 | DeferStmt :: a 101 | -> f Expr -- ^ call expression 102 | -> NodeF a f Stmt 103 | 104 | EmptyStmt :: a -> NodeF a f Stmt 105 | 106 | -- | A (stand-alone) expression in a statement list. 107 | ExprStmt :: a 108 | -> f Expr 109 | -> NodeF a f Stmt 110 | 111 | ForStmt :: a 112 | -> Maybe (f Stmt) -- ^ initialization statement; or nil 113 | -> Maybe (f Expr) -- ^ condition; or nil 114 | -> Maybe (f Stmt) -- ^ post iteration statement; or nil 115 | -> f Block -- ^ loop body 116 | -> NodeF a f Stmt 117 | 118 | GoStmt :: a 119 | -> f Expr -- ^ call expression 120 | -> NodeF a f Stmt 121 | 122 | IfStmt :: a 123 | -> Maybe (f Stmt) -- ^ initialization statement; or nil 124 | -> f Expr -- ^ condition 125 | -> f Block -- ^ body 126 | -> Maybe (f Stmt) -- ^ else branch; or nil 127 | -> NodeF a f Stmt 128 | 129 | -- | An increment or decrement statement. 130 | IncDecStmt :: a 131 | -> f Expr -- ^ inner expression 132 | -> Bool -- ^ true if increment, false if decrement 133 | -> NodeF a f Stmt 134 | 135 | LabeledStmt :: a 136 | -> Ident -- ^ label 137 | -> f Stmt 138 | -> NodeF a f Stmt 139 | 140 | -- | A for statement with a range clause. 141 | RangeStmt :: a 142 | -> Maybe (f Expr) -- ^ key 143 | -> Maybe (f Expr) -- ^ value 144 | -> f Expr -- ^ value to range over 145 | -> f Block -- ^ body 146 | -> Bool -- ^ is assign? 147 | -> NodeF a f Stmt 148 | 149 | ReturnStmt :: a 150 | -> [f Expr] -- ^ result expressions 151 | -> NodeF a f Stmt 152 | 153 | SelectStmt :: a 154 | -> f Block -- ^ body (CommClauseStmts only) 155 | -> NodeF a f Stmt 156 | 157 | SendStmt :: a 158 | -> f Expr -- ^ channel 159 | -> f Expr -- ^ value 160 | -> NodeF a f Stmt 161 | 162 | -- | An expression switch statement. 163 | SwitchStmt :: a 164 | -> Maybe (f Stmt) -- ^ initialization statement; or nil 165 | -> Maybe (f Expr) -- ^ tag expression; or nil 166 | -> f Block -- ^ body (CaseClauseStmts only) 167 | -> NodeF a f Stmt 168 | 169 | TypeSwitchStmt :: a 170 | -> Maybe (f Stmt) -- ^ initialization statement; or nil 171 | -> f Stmt -- ^ x := y.(type) or y.(type) 172 | -> f Block -- ^ body (CaseClauseStmts only) 173 | -> NodeF a f Stmt 174 | 175 | -- | A case of an expression or type switch statement. 176 | CaseClauseStmt :: a 177 | -> [f Expr] -- ^ list of expressions or types; nil 178 | -- means default case 179 | -> [f Stmt] -- ^ statement list 180 | -> NodeF a f Stmt 181 | 182 | -- | A case of a select statement. 183 | CommClauseStmt :: a 184 | -> Maybe (f Stmt) -- ^ send or receive statement; nil 185 | -- means default case 186 | -> [f Stmt] -- ^ body 187 | -> NodeF a f Stmt 188 | 189 | -- | A top-level initializer (never appears in source code, 190 | -- generated by Go's typechecker). 191 | InitializerStmt :: [f Expr] -- ^ list of constant/variable identifiers 192 | -> [f Expr] -- ^ initial values 193 | -> NodeF a f Stmt 194 | 195 | ---------------------------------------------------------------------- 196 | -- Expressions 197 | 198 | -- | A literal of basic type. 199 | BasicLitExpr :: a -> Type -> BasicLit -> NodeF a f Expr 200 | 201 | -- | A constant value produced by the Go typechecker's constant 202 | -- evaluator (most literals end up as one of these rather than a 203 | -- BasicLitExpr). 204 | BasicConstExpr :: a -> Type -> BasicConst -> NodeF a f Expr 205 | 206 | BinaryExpr :: a -> Type 207 | -> f Expr -- ^ left operand 208 | -> BinaryOp -- ^ operator 209 | -> f Expr -- ^ right operand 210 | -> NodeF a f Expr 211 | 212 | -- | An expression followed by an argument list. 213 | CallExpr :: a -> Type 214 | -> Bool -- ^ true if the last argument is an ellipsis 215 | -> f Expr -- ^ function expression 216 | -> [f Expr] -- ^ function arguments 217 | -> NodeF a f Expr 218 | 219 | CastExpr :: a -> Type 220 | -> f Expr -- ^ expression being cast 221 | -> f Expr -- ^ type to cast to 222 | -> NodeF a f Expr 223 | 224 | -- | A composite literal. 225 | CompositeLitExpr :: a -> Type 226 | -> Maybe (f Expr) -- ^ literal type; or nil 227 | -> [f Expr] -- ^ list of composite elements 228 | -> NodeF a f Expr 229 | 230 | IdentExpr :: a -> Type 231 | -> Maybe Ident -- ^ Optional qualifier 232 | -> Ident -- ^ name 233 | -> NodeF a f Expr 234 | 235 | -- | An Ellipsis node stands for the "..." type in a parameter list 236 | -- or the "..." length in an array type. 237 | EllipsisExpr :: a -> Type 238 | -> Maybe (f Expr) -- ^ ellipsis element type (parameter 239 | -- lists only); or nil 240 | -> NodeF a f Expr 241 | 242 | -- | A function literal. 243 | FuncLitExpr :: a -> Type 244 | -> [f Field] -- ^ function parameter types 245 | -> [f Field] -- ^ function return types 246 | -> f Block -- ^ function body 247 | -> NodeF a f Expr 248 | 249 | -- | An expression followed by an index. 250 | IndexExpr :: a -> Type 251 | -> f Expr -- ^ expression 252 | -> f Expr -- ^ index 253 | -> NodeF a f Expr 254 | 255 | -- | (key : value) pairs in composite literals. 256 | KeyValueExpr :: a -> Type 257 | -> f Expr -- ^ key 258 | -> f Expr -- ^ value 259 | -> NodeF a f Expr 260 | 261 | -- | A parenthesized expression. 262 | ParenExpr :: a -> Type 263 | -> f Expr -- ^ parenthesized expression 264 | -> NodeF a f Expr 265 | 266 | -- | An expression followed by a selector. 267 | SelectorExpr :: a -> Type 268 | -> f Expr -- ^ expression 269 | -> Ident -- ^ field selector 270 | -> NodeF a f Expr 271 | 272 | -- | An expression followed by slice indices. 273 | SliceExpr :: a -> Type 274 | -> f Expr -- ^ expression 275 | -> Maybe (f Expr) -- ^ begin of slice range; or nil 276 | -> Maybe (f Expr) -- ^ end of slice range; or nil 277 | -> Maybe (f Expr) -- ^ maximum capacity of slice; or nil 278 | -> Bool -- ^ true if 3-index slice (2 colons present) 279 | -> NodeF a f Expr 280 | 281 | -- | An expression of the form "*" Expression. 282 | StarExpr :: a -> Type 283 | -> f Expr -- ^ operand 284 | -> NodeF a f Expr 285 | 286 | -- | An expression followed by a type assertion. 287 | TypeAssertExpr :: a -> Type 288 | -> f Expr -- ^ expression 289 | -> Maybe (f Expr) -- ^ asserted type; nil means type 290 | -- switch X.(type) 291 | -> NodeF a f Expr 292 | 293 | -- | A unary expression. Unary "*" expressions are represented via 294 | -- StarExpr nodes. 295 | UnaryExpr :: a -> Type 296 | -> UnaryOp -- ^ operator 297 | -> f Expr -- ^ operand 298 | -> NodeF a f Expr 299 | 300 | ---------------------------------------------------------------------- 301 | -- Type expressions 302 | 303 | -- | Named type (includes basic types like bool, int32, etc.) 304 | NamedTypeExpr :: a -> Type -> Ident -> NodeF a f Expr 305 | 306 | PointerTypeExpr :: a -> Type 307 | -> f Expr 308 | -> NodeF a f Expr 309 | 310 | -- | An array or slice type. 311 | ArrayTypeExpr :: a -> Type 312 | -> Maybe (f Expr) -- ^ length. Ellipsis for [...]T 313 | -- array types, nil for slice types 314 | -> f Expr -- ^ element type 315 | -> NodeF a f Expr 316 | 317 | FuncTypeExpr :: a -> Type 318 | -> [f Field] -- ^ (incoming) parameters; non-nil 319 | -> Maybe (f Field) -- ^ variadic parameter 320 | -> [f Field] -- ^ (outgoing) results 321 | -> NodeF a f Expr 322 | 323 | InterfaceTypeExpr :: a -> Type 324 | -> [f Field] -- ^ list of methods 325 | -> Bool -- ^ true if (source) methods are missing 326 | -- in the methods list 327 | -> NodeF a f Expr 328 | 329 | MapTypeExpr :: a -> Type 330 | -> f Expr -- ^ key type 331 | -> f Expr -- ^ value type 332 | -> NodeF a f Expr 333 | 334 | StructTypeExpr :: a -> Type 335 | -> [f Field] -- ^ list of field declarations 336 | -> NodeF a f Expr 337 | 338 | ChanTypeExpr :: a -> Type 339 | -> ChanDir -- ^ channel direction 340 | -> f Expr -- ^ value type 341 | -> NodeF a f Expr 342 | 343 | -- | Internal language only 344 | TupleExpr :: a -> Type 345 | -> [f Expr] 346 | -> NodeF a f Expr 347 | 348 | -- | Internal language only 349 | ProjExpr :: a -> Type 350 | -> f Expr 351 | -> Int 352 | -> NodeF a f Expr 353 | 354 | -- | Internal language only 355 | NilExpr :: a -> Type -> NodeF a f Expr 356 | 357 | ---------------------------------------------------------------------- 358 | -- Declarations 359 | 360 | FuncDecl :: a 361 | -> Maybe (f Field) -- ^ receiver (methods); or nil (functions) 362 | -> Ident -- ^ function/method name 363 | -> [f Field] -- ^ parameters 364 | -> Maybe (f Field) -- ^ variadic parameter 365 | -> [f Field] -- ^ results 366 | -> Maybe (f Block) -- ^ function body; or nil for external 367 | -- (non-Go) function 368 | -> NodeF a f Decl 369 | 370 | -- | (generic declaration node) An import, constant, type or 371 | -- variable declaration. 372 | GenDecl :: a 373 | -> [f Spec] -- ^ specs 374 | -> NodeF a f Decl 375 | 376 | TypeAliasDecl :: a 377 | -> [f Bind] 378 | -> NodeF a f Decl 379 | 380 | ---------------------------------------------------------------------- 381 | -- Variable type binding 382 | 383 | Binding :: Ident 384 | -> f Expr 385 | -> NodeF a f Bind 386 | 387 | ---------------------------------------------------------------------- 388 | -- Specifications 389 | 390 | -- | A single package import. 391 | ImportSpec :: a 392 | -> Maybe Ident -- ^ local package name (including "."); or nil 393 | -> Text -- ^ import path 394 | -> NodeF a f Spec 395 | 396 | -- | A constant declaration. 397 | ConstSpec :: a 398 | -> [Ident] -- ^ value names (nonempty) 399 | -> Maybe (f Expr) -- ^ value type; or nil 400 | -> [f Expr] -- ^ initial values 401 | -> NodeF a f Spec 402 | 403 | -- | A variable declaration. 404 | VarSpec :: a 405 | -> [Ident] -- ^ value names (nonempty) 406 | -> Maybe (f Expr) -- ^ value type; or nil 407 | -> [f Expr] -- ^ initial values 408 | -> NodeF a f Spec 409 | 410 | -- | A type declaration (TypeSpec production). 411 | TypeSpec :: a 412 | -> Ident -- ^ type name 413 | -> f Expr -- ^ IdentExpr, ParenExpr, SelectorExpr, 414 | -- StarExpr, or any xxxTypeExpr 415 | -> NodeF a f Spec 416 | 417 | ---------------------------------------------------------------------- 418 | -- Misc. 419 | 420 | -- | A Field represents a Field declaration list in a struct type, a 421 | -- method list in an interface type, or a parameter/result 422 | -- declaration in a signature. Field.Names is nil for unnamed 423 | -- parameters (parameter lists which only contain types) and 424 | -- embedded struct fields. In the latter case, the field name is the 425 | -- type name. 426 | FieldNode :: [Ident] -- ^ field/method/parameter names; or nil 427 | -> f Expr -- ^ field/method/parameter type 428 | -> Maybe BasicLit -- ^ field tag; or nil 429 | -> NodeF a f Field 430 | 431 | -- | A braced statement list. 432 | BlockNode :: [f Stmt] 433 | -> NodeF a f Block 434 | 435 | data AssignType = 436 | Assign 437 | | Define 438 | | AssignOperator 439 | deriving (Eq, Show) 440 | 441 | data BranchType = 442 | Break 443 | | Continue 444 | | Goto 445 | | Fallthrough 446 | deriving (Eq, Show) 447 | 448 | data BasicLitType = 449 | LiteralBool 450 | | LiteralInt 451 | | LiteralFloat 452 | | LiteralComplex 453 | | LiteralImag 454 | | LiteralChar 455 | | LiteralString 456 | deriving (Eq, Show) 457 | 458 | -- | A literal of basic type. 459 | data BasicLit = 460 | BasicLit 461 | { basiclit_type :: BasicLitType -- ^ "kind" of the literal 462 | , basiclit_value :: Text -- ^ literal value as a string 463 | } 464 | deriving (Eq, Show) 465 | 466 | -- | Float constants are represented by rationals by Go's constant evaluator. 467 | data BasicConst = 468 | BasicConstBool Bool 469 | | BasicConstString Text 470 | | BasicConstInt Integer 471 | | BasicConstFloat BasicConst BasicConst -- ^ Numerator and denominator ints 472 | | BasicConstComplex BasicConst BasicConst -- ^ Real and imaginary floats 473 | deriving (Eq, Show) 474 | 475 | data BinaryOp = 476 | BPlus -- ^ + 477 | | BMinus -- ^ - 478 | | BMult -- ^ * 479 | | BDiv -- ^ / 480 | | BMod -- ^ % 481 | | BAnd -- ^ & 482 | | BOr -- ^ | 483 | | BXor -- ^ ^ 484 | | BShiftL -- ^ << 485 | | BShiftR -- ^ >> 486 | | BAndNot -- ^ &^ 487 | | BLAnd -- ^ logical AND 488 | | BLOr -- ^ logical OR 489 | | BEq -- ^ == 490 | | BLt -- ^ < 491 | | BGt -- ^ > 492 | | BNeq -- ^ != 493 | | BLeq -- ^ <= 494 | | BGeq -- ^ >= 495 | deriving (Eq, Show) 496 | 497 | data UnaryOp = 498 | UPlus -- ^ + 499 | | UMinus -- ^ - 500 | | UNot -- ^ ! 501 | | UBitwiseNot -- ^ ^ 502 | | UStar -- ^ * 503 | | UAddress -- ^ & 504 | | UArrow -- ^ <- 505 | deriving (Eq, Show) 506 | 507 | annotOf :: NodeF a f Expr -> a 508 | annotOf (BasicLitExpr x _ _) = x 509 | annotOf (BasicConstExpr x _ _) = x 510 | annotOf (BinaryExpr x _ _ _ _) = x 511 | annotOf (CallExpr x _ _ _ _) = x 512 | annotOf (CastExpr x _ _ _) = x 513 | annotOf (CompositeLitExpr x _ _ _) = x 514 | annotOf (IdentExpr x _ _ _) = x 515 | annotOf (EllipsisExpr x _ _) = x 516 | annotOf (FuncLitExpr x _ _ _ _) = x 517 | annotOf (IndexExpr x _ _ _) = x 518 | annotOf (KeyValueExpr x _ _ _) = x 519 | annotOf (ParenExpr x _ _) = x 520 | annotOf (SelectorExpr x _ _ _) = x 521 | annotOf (SliceExpr x _ _ _ _ _ _) = x 522 | annotOf (StarExpr x _ _) = x 523 | annotOf (TypeAssertExpr x _ _ _) = x 524 | annotOf (UnaryExpr x _ _ _) = x 525 | annotOf (NamedTypeExpr x _ _) = x 526 | annotOf (PointerTypeExpr x _ _) = x 527 | annotOf (ArrayTypeExpr x _ _ _) = x 528 | annotOf (FuncTypeExpr x _ _ _ _) = x 529 | annotOf (InterfaceTypeExpr x _ _ _) = x 530 | annotOf (MapTypeExpr x _ _ _) = x 531 | annotOf (StructTypeExpr x _ _) = x 532 | annotOf (ChanTypeExpr x _ _ _) = x 533 | annotOf (TupleExpr x _ _) = x 534 | annotOf (ProjExpr x _ _ _) = x 535 | annotOf (NilExpr x _) = x 536 | 537 | annotOf' :: Node a Expr -> a 538 | annotOf' = annotOf . out 539 | 540 | typeOf :: NodeF a f Expr -> Type 541 | typeOf (BasicLitExpr _ tp _) = tp 542 | typeOf (BasicConstExpr _ tp _) = tp 543 | typeOf (BinaryExpr _ tp _ _ _) = tp 544 | typeOf (CallExpr _ tp _ _ _) = tp 545 | typeOf (CastExpr _ tp _ _) = tp 546 | typeOf (CompositeLitExpr _ tp _ _) = tp 547 | typeOf (IdentExpr _ tp _ _) = tp 548 | typeOf (EllipsisExpr _ tp _) = tp 549 | typeOf (FuncLitExpr _ tp _ _ _) = tp 550 | typeOf (IndexExpr _ tp _ _) = tp 551 | typeOf (KeyValueExpr _ tp _ _) = tp 552 | typeOf (ParenExpr _ tp _) = tp 553 | typeOf (SelectorExpr _ tp _ _) = tp 554 | typeOf (SliceExpr _ tp _ _ _ _ _) = tp 555 | typeOf (StarExpr _ tp _) = tp 556 | typeOf (TypeAssertExpr _ tp _ _) = tp 557 | typeOf (UnaryExpr _ tp _ _) = tp 558 | typeOf (NamedTypeExpr _ tp _) = tp 559 | typeOf (PointerTypeExpr _ tp _) = tp 560 | typeOf (ArrayTypeExpr _ tp _ _) = tp 561 | typeOf (FuncTypeExpr _ tp _ _ _) = tp 562 | typeOf (InterfaceTypeExpr _ tp _ _) = tp 563 | typeOf (MapTypeExpr _ tp _ _) = tp 564 | typeOf (StructTypeExpr _ tp _) = tp 565 | typeOf (ChanTypeExpr _ tp _ _) = tp 566 | typeOf (TupleExpr _ tp _) = tp 567 | typeOf (ProjExpr _ tp _ _) = tp 568 | typeOf (NilExpr _ tp) = tp 569 | 570 | typeOf' :: Node a Expr -> Type 571 | typeOf' = typeOf . out 572 | 573 | deriving instance (Eq a, forall n. Eq (f n)) => Eq (NodeF a f i) 574 | deriving instance (Show a, forall n. Show (f n)) => Show (NodeF a f i) 575 | deriving instance Eq a => Eq (Fix (NodeF a) i) 576 | deriving instance Show a => Show (Fix (NodeF a) i) 577 | 578 | -- $(return []) 579 | 580 | instance FunctorFC (NodeF a) where 581 | fmapFC = fmapFCDefault 582 | 583 | instance FoldableFC (NodeF a) where 584 | foldMapFC = foldMapFCDefault 585 | 586 | -- It would be nice to derive this automatically using 587 | -- structuralTraversal. 588 | instance TraversableFC (NodeF a) where 589 | traverseFC f (MainNode nm pkg pkgs) = 590 | MainNode nm <$> f pkg <*> traverse f pkgs 591 | traverseFC f (PackageNode name path imports file_paths files inits) = 592 | PackageNode name path imports file_paths <$> 593 | traverse f files <*> traverse f inits 594 | traverseFC f (FileNode path name decls imports) = 595 | FileNode path name <$> traverse f decls <*> traverse f imports 596 | traverseFC f (BlockNode stmts) = BlockNode <$> traverse f stmts 597 | traverseFC f (AssignStmt x tp op lhs rhs) = 598 | AssignStmt x tp op <$> traverse f lhs <*> traverse f rhs 599 | traverseFC f (BlockStmt x stmt) = BlockStmt x <$> f stmt 600 | traverseFC _f (BranchStmt x tp lbl) = pure $ BranchStmt x tp lbl 601 | traverseFC f (DeclStmt x decl) = DeclStmt x <$> f decl 602 | traverseFC f (DeferStmt x e) = DeferStmt x <$> f e 603 | traverseFC _f (EmptyStmt x) = pure $ EmptyStmt x 604 | traverseFC f (ExprStmt x e) = ExprStmt x <$> f e 605 | traverseFC f (ForStmt x ini cond post body) = 606 | ForStmt x <$> traverse f ini <*> 607 | traverse f cond <*> traverse f post <*> f body 608 | traverseFC f (GoStmt x e) = GoStmt x <$> f e 609 | traverseFC f (IfStmt x ini cond body els) = 610 | IfStmt x <$> traverse f ini <*> f cond <*> f body <*> traverse f els 611 | traverseFC f (IncDecStmt x e b) = IncDecStmt x <$> f e <*> pure b 612 | traverseFC f (LabeledStmt x lbl stmt) = LabeledStmt x lbl <$> f stmt 613 | traverseFC f (RangeStmt x key value range body assign) = 614 | RangeStmt x <$> traverse f key <*> 615 | traverse f value <*> f range <*> f body <*> pure assign 616 | traverseFC f (ReturnStmt x es) = ReturnStmt x <$> traverse f es 617 | traverseFC f (SelectStmt x body) = SelectStmt x <$> f body 618 | traverseFC f (SendStmt x chan value) = SendStmt x <$> f chan <*> f value 619 | traverseFC f (SwitchStmt x ini tag body) = 620 | SwitchStmt x <$> traverse f ini <*> traverse f tag <*> f body 621 | traverseFC f (TypeSwitchStmt x ini assign body) = 622 | TypeSwitchStmt x <$> traverse f ini <*> f assign <*> f body 623 | traverseFC f (CaseClauseStmt x es stmts) = 624 | CaseClauseStmt x <$> traverse f es <*> traverse f stmts 625 | traverseFC f (CommClauseStmt x stmt stmts) = 626 | CommClauseStmt x <$> traverse f stmt <*> traverse f stmts 627 | traverseFC f (InitializerStmt vars values) = 628 | InitializerStmt <$> traverse f vars <*> traverse f values 629 | traverseFC _f (BasicLitExpr x tp lit) = pure $ BasicLitExpr x tp lit 630 | traverseFC _f (BasicConstExpr x tp c) = pure $ BasicConstExpr x tp c 631 | traverseFC f (BinaryExpr x tp left op right) = 632 | BinaryExpr x tp <$> f left <*> pure op <*> f right 633 | traverseFC f (CallExpr x tp b fun args) = 634 | CallExpr x tp b <$> f fun <*> traverse f args 635 | traverseFC f (CastExpr x tp e ty) = CastExpr x tp <$> f e <*> f ty 636 | traverseFC f (CompositeLitExpr x tp ty es) = 637 | CompositeLitExpr x tp <$> traverse f ty <*> traverse f es 638 | traverseFC _f (IdentExpr x tp qual ident) = pure $ IdentExpr x tp qual ident 639 | traverseFC f (EllipsisExpr x tp ty) = EllipsisExpr x tp <$> traverse f ty 640 | traverseFC f (FuncLitExpr x tp params results body) = 641 | FuncLitExpr x tp <$> traverse f params <*> traverse f results <*> f body 642 | traverseFC f (IndexExpr x tp e ix) = IndexExpr x tp <$> f e <*> f ix 643 | traverseFC f (KeyValueExpr x tp key value) = 644 | KeyValueExpr x tp <$> f key <*> f value 645 | traverseFC f (ParenExpr x tp e) = ParenExpr x tp <$> f e 646 | traverseFC f (SelectorExpr x tp e ident) = 647 | SelectorExpr x tp <$> f e <*> pure ident 648 | traverseFC f (SliceExpr x tp e begin end m b) = 649 | SliceExpr x tp <$> f e <*> traverse f begin <*> 650 | traverse f end <*> traverse f m <*> pure b 651 | traverseFC f (StarExpr x tp e) = StarExpr x tp <$> f e 652 | traverseFC f (TypeAssertExpr x tp e ty) = 653 | TypeAssertExpr x tp <$> f e <*> traverse f ty 654 | traverseFC f (UnaryExpr x tp op e) = UnaryExpr x tp op <$> f e 655 | traverseFC _f (NamedTypeExpr x tp nm) = pure $ NamedTypeExpr x tp nm 656 | traverseFC f (PointerTypeExpr x tp ty) = PointerTypeExpr x tp <$> f ty 657 | traverseFC f (ArrayTypeExpr x tp len ty) = 658 | ArrayTypeExpr x tp <$> traverse f len <*> f ty 659 | traverseFC f (FuncTypeExpr x tp params variadic results) = 660 | FuncTypeExpr x tp <$> traverse f params <*> 661 | traverse f variadic <*> traverse f results 662 | traverseFC f (InterfaceTypeExpr x tp methods b) = 663 | InterfaceTypeExpr x tp <$> traverse f methods <*> pure b 664 | traverseFC f (MapTypeExpr x tp key value) = 665 | MapTypeExpr x tp <$> f key <*> f value 666 | traverseFC f (StructTypeExpr x tp fields) = 667 | StructTypeExpr x tp <$> traverse f fields 668 | traverseFC f (ChanTypeExpr x tp dir ty) = ChanTypeExpr x tp dir <$> f ty 669 | traverseFC f (TupleExpr x tp es) = TupleExpr x tp <$> traverse f es 670 | traverseFC f (ProjExpr x tp e i) = ProjExpr x tp <$> f e <*> pure i 671 | traverseFC _f (NilExpr x tp) = pure $ NilExpr x tp 672 | traverseFC f (FuncDecl x recv nm params variadic results body) = 673 | FuncDecl x <$> traverse f recv <*> pure nm <*> traverse f params <*> 674 | traverse f variadic <*> traverse f results <*> traverse f body 675 | traverseFC f (GenDecl x specs) = GenDecl x <$> traverse f specs 676 | traverseFC f (TypeAliasDecl x binds) = TypeAliasDecl x <$> traverse f binds 677 | traverseFC f (Binding ident e) = Binding ident <$> f e 678 | traverseFC _f (ImportSpec x name path) = pure $ ImportSpec x name path 679 | traverseFC f (ConstSpec x names ty es) = 680 | ConstSpec x names <$> traverse f ty <*> traverse f es 681 | traverseFC f (VarSpec x names ty es) = 682 | VarSpec x names <$> traverse f ty <*> traverse f es 683 | traverseFC f (TypeSpec x name e) = TypeSpec x name <$> f e 684 | traverseFC f (FieldNode names ty tag) = FieldNode names <$> f ty <*> pure tag 685 | 686 | -- TODO 687 | -- traverseNodeF :: forall m a f g tp. Applicative m => 688 | -- (forall u. f u -> m (g u)) -> 689 | -- NodeF a f tp -> m (NodeF a g tp) 690 | -- -- traverseNodeF = $(U.structuralTraversal [t|NodeF|] []) 691 | -- traverseNodeF = $(U.structuralTraversal [t|NodeF|] 692 | -- -- [(U.ConType [t|[]|] `U.TypeApp` U.AnyType, [|traverse|]) 693 | -- -- , (U.ConType [t|Maybe|] `U.TypeApp` U.AnyType, [|traverse|])] 694 | -- -- [(U.ConType [t|[]|] `U.TypeApp` U.AnyType `U.TypeApp` U.AnyType, [|traverse|]), 695 | -- [ 696 | -- -- (U.ConType [t|Maybe|] `U.TypeApp` (U.AnyType `U.TypeApp` U.AnyType), [|traverse|]) 697 | -- ] 698 | -- ) 699 | 700 | -- -- traverseNodeF :: forall ext m f g tp. Applicative m 701 | -- -- => (forall u . f u -> m (g u)) 702 | -- -- -> NodeF ext f tp -> m (NodeF ext g tp) 703 | -- -- traverseNodeF = $(U.structuralTraversal [t|NodeF|] []) 704 | 705 | -- instance TraversableFC (NodeF a) where 706 | -- -- traverseFC = $(U.structuralTraversal [t|NodeF|] []) 707 | -- traverseFC = traverseNodeF 708 | 709 | packageName :: Node a Package -> Text 710 | packageName (In (PackageNode nm _path _imports _file_paths _files _inits)) = nm 711 | 712 | fileName :: Node a File -> Text 713 | fileName (In (FileNode _path (Ident _k nm) _decls _imports)) = nm 714 | 715 | fieldType :: Node a Field -> Type 716 | fieldType (In (FieldNode _names tp_expr _tag)) = typeOf' tp_expr 717 | 718 | declSpecs :: Node a Decl -> [Node a Spec] 719 | declSpecs (In (GenDecl _x specs)) = specs 720 | declSpecs _decl = error "declSpecs: expected GenDecl" 721 | 722 | readBool :: Text -> Bool 723 | readBool s = case s of 724 | "true" -> True 725 | "false" -> False 726 | _ -> error $ "readBool: not a bool: " ++ show s 727 | 728 | isLoop :: Node a tp -> Bool 729 | isLoop (In (ForStmt _x _ini _cond _post _body)) = True 730 | isLoop (In (RangeStmt _x _k _v _e _body _assign)) = True 731 | isLoop _node = False 732 | 733 | boolConst :: a -> Bool -> Node a Expr 734 | boolConst x b = In $ BasicConstExpr x boolType (BasicConstBool b) 735 | 736 | intConst :: a -> Maybe Int -> Integer -> Node a Expr 737 | intConst x w i = In $ BasicConstExpr x (intType w) (BasicConstInt i) 738 | 739 | uintConst :: a -> Maybe Int -> Integer -> Node a Expr 740 | uintConst x w i = In $ BasicConstExpr x (uintType w) (BasicConstInt i) 741 | 742 | floatConst :: a -> Int -> BasicConst -> BasicConst -> Node a Expr 743 | floatConst x w num denom = 744 | In $ BasicConstExpr x (floatType w) (BasicConstFloat num denom) 745 | 746 | complexConst :: a -> Int -> BasicConst -> BasicConst -> Node a Expr 747 | complexConst x w real imag = 748 | In $ BasicConstExpr x (complexType w) (BasicConstComplex real imag) 749 | 750 | stringConst :: a -> Text -> Node a Expr 751 | stringConst x str = In $ BasicConstExpr x stringType $ BasicConstString str 752 | 753 | -- | Zero value expressions for every type. 754 | zeroExpr :: a -> Type -> Node a Expr 755 | zeroExpr _ NoType = error "zeroExpr: NoType" 756 | zeroExpr x (ArrayType len tp) = zeroArray x len tp 757 | zeroExpr x (BasicType basicKind) = zeroBasic x basicKind 758 | zeroExpr x tp@(ChanType _dir _tp) = In $ NilExpr x tp 759 | zeroExpr x tp@(InterfaceType _fields) = In $ NilExpr x tp 760 | zeroExpr x tp@(MapType _s _t) = In $ NilExpr x tp 761 | zeroExpr x (NamedType tp) = zeroExpr x tp 762 | zeroExpr x tp@(PointerType _tp) = In $ NilExpr x tp 763 | zeroExpr x tp@(FuncType _recv _params _return _variadic) = In $ NilExpr x tp 764 | zeroExpr x tp@(SliceType _tp) = In $ NilExpr x tp 765 | zeroExpr _ (StructType _fields) = error "zeroExpr: struct not yet supported" 766 | zeroExpr x (TupleType fields) = zeroTuple x fields 767 | 768 | zeroBasic :: a -> BasicKind -> Node a Expr 769 | zeroBasic _ BasicInvalid = error "" 770 | zeroBasic x BasicBool = boolConst x False 771 | zeroBasic x (BasicInt w) = intConst x w 0 772 | zeroBasic x (BasicUInt w) = uintConst x w 0 773 | zeroBasic x BasicUIntptr = In $ NilExpr x $ BasicType BasicUIntptr 774 | zeroBasic x (BasicFloat w) = floatConst x w (BasicConstInt 0) (BasicConstInt 1) 775 | zeroBasic x (BasicComplex w) = 776 | complexConst x w (BasicConstFloat (BasicConstInt 0) (BasicConstInt 1)) 777 | (BasicConstFloat (BasicConstInt 0) (BasicConstInt 1)) 778 | zeroBasic x BasicString = stringConst x "" 779 | zeroBasic x BasicUnsafePointer = In $ NilExpr x $ BasicType BasicUnsafePointer 780 | zeroBasic x (BasicUntyped untypedKind) = zeroUntyped x untypedKind 781 | 782 | zeroUntyped :: a -> UntypedKind -> Node a Expr 783 | zeroUntyped x UntypedBool = boolConst x False 784 | zeroUntyped x UntypedInt = intConst x Nothing 0 785 | zeroUntyped x UntypedRune = intConst x (Just 8) 0 786 | zeroUntyped x UntypedFloat = floatConst x 64 (BasicConstInt 0) (BasicConstInt 1) 787 | zeroUntyped x UntypedComplex = 788 | complexConst x (128) (BasicConstFloat (BasicConstInt 0) (BasicConstInt 1)) 789 | (BasicConstFloat (BasicConstInt 0) (BasicConstInt 1)) 790 | zeroUntyped x UntypedString = stringConst x "" 791 | zeroUntyped x UntypedNil = In $ NilExpr x $ BasicType $ BasicUntyped UntypedNil 792 | 793 | zeroArray :: a -> Int -> Type -> Node a Expr 794 | zeroArray x len tp = 795 | In $ CompositeLitExpr x (ArrayType len tp) Nothing $ 796 | replicate len $ zeroExpr x tp 797 | 798 | zeroTuple :: a -> [NameType] -> Node a Expr 799 | zeroTuple x tps = 800 | In $ TupleExpr x (TupleType tps) $ zeroExpr x . typeOfNameType <$> tps 801 | -------------------------------------------------------------------------------- /src/Language/Go/Desugar.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Language.Go.Desugar 3 | Description : Go syntax desugarer 4 | Maintainer : abagnall@galois.com 5 | Stability : experimental 6 | 7 | "Desugaring" phase of the go frontend. Applies the following syntactic 8 | transformations: 9 | * replace nil idents with NilExprs and type idents with NamedTypeExprs. 10 | * introduce/eliminate tuples where "multi-values" appear. 11 | * convert variadic arguments to slice literals. 12 | * insert missing return statements and fill in "naked returns". 13 | * replace increment and decrement statements with assign statements. 14 | * eliminate assign operators (e.g., x += 1 becomes x = x + 1). 15 | * replace 'x != y' binary expressions with '!(x == y)'. 16 | * replace 'x[i]' with '(*x)[i]' when x is a pointer to an array. 17 | * fill variable declarations with no initial values with zero 18 | values. e.g., 'var x int32' becomes 'var x int32 = 0'. 19 | * rewrite 'range' loops to 'for' loops (not for maps). 20 | -} 21 | {-# LANGUAGE DataKinds #-} 22 | {-# LANGUAGE GADTs #-} 23 | {-# LANGUAGE KindSignatures #-} 24 | {-# LANGUAGE OverloadedStrings #-} 25 | module Language.Go.Desugar (desugar) where 26 | 27 | import Control.Monad.Except 28 | import Control.Monad.Identity 29 | 30 | import Language.Go.AST 31 | import Language.Go.Rec 32 | import Language.Go.Types 33 | 34 | -- | Entry point of the module. 35 | desugar :: Show a => Node a tp -> Node a tp 36 | desugar node = case runDesugarM $ cataM desugar_alg node of 37 | Left msg -> error msg 38 | Right node' -> node' 39 | 40 | type DesugarM a = ExceptT String Identity a 41 | 42 | runDesugarM :: DesugarM a -> Either String a 43 | runDesugarM = runIdentity . runExceptT 44 | 45 | -- | The desugar algebra. 46 | desugar_alg :: Show a => NodeF a (Node a) tp -> DesugarM (Node a tp) 47 | 48 | -- | Convert nil and type identifiers to their own different syntactic 49 | -- forms so all remaining identifiers are term-level identifiers 50 | -- (variables, functions, etc.). 51 | desugar_alg (IdentExpr x tp qual (Ident kind name)) = 52 | return $ In $ case kind of 53 | IdentNil -> NilExpr x NoType 54 | IdentTypeName -> NamedTypeExpr x tp (Ident kind name) 55 | -- TODO: IOTA? 56 | _ -> IdentExpr x tp qual (Ident kind name) 57 | 58 | -- | Generate projections for the RHS when it's a tuple. 59 | desugar_alg (AssignStmt x assign_tp op lhs rhs) = 60 | return $ case (assign_tp, op, lhs, rhs) of 61 | (AssignOperator, Just binop, [l], [r]) -> mkBinopAssign x Assign binop l r 62 | (_tp, _op, _l, _r) -> 63 | In $ AssignStmt x assign_tp op lhs $ unpack_tuple rhs 64 | 65 | desugar_alg (ConstSpec x names ty values) = case (ty, values) of 66 | (Just ty', []) -> 67 | return $ In $ ConstSpec x names ty $ zeroExpr x (typeOf' ty') <$ names 68 | _ -> 69 | return $ In $ ConstSpec x names ty $ unpack_tuple values 70 | 71 | desugar_alg (VarSpec x names ty values) = case (ty, values) of 72 | (Just ty', []) -> 73 | return $ In $ VarSpec x names ty $ zeroExpr x (typeOf' ty') <$ names 74 | _ -> 75 | return $ In $ VarSpec x names ty $ unpack_tuple values 76 | 77 | desugar_alg (InitializerStmt vars values) = 78 | return $ In $ InitializerStmt vars $ unpack_tuple values 79 | 80 | -- | Pack results into a tuple, unless there is exactly one return value. 81 | desugar_alg (ReturnStmt x results) = 82 | return $ In $ ReturnStmt x $ 83 | if length results == 1 then results else 84 | [In $ 85 | TupleExpr x (TupleType $ typeToNameType . typeOf' <$> results) results] 86 | 87 | -- | Generate projections for arguments in the case of a single tuple 88 | -- argument, and deal with variadic arguments. 89 | desugar_alg (CallExpr x tp ellipsis fun args) = 90 | case typeOf' fun of 91 | FuncType _recv params _result variadic -> 92 | if variadic then 93 | let regular_params = init params 94 | args' = unpack_tuple args 95 | n = length regular_params 96 | regular_args = take n args' 97 | variadic_arg = case drop n args' of 98 | -- It could be an actual slice value with the ellipsis syntax. 99 | [e] | ellipsis -> e 100 | -- Otherwise pack all of the variadic arguments into a 101 | -- slice literal. Use Nothing for the syntactic type 102 | -- field since we don't need it. Use 'last params' 103 | -- (always a slice type) for the semantic type. 104 | args'' -> 105 | In $ CompositeLitExpr x (last params) Nothing args'' 106 | in 107 | return $ In $ CallExpr x tp False fun $ regular_args ++ [variadic_arg] 108 | else 109 | return $ In $ CallExpr x tp False fun $ unpack_tuple args 110 | _ -> 111 | throwError $ "desugar_alg: expected FuncType, got " ++ show (typeOf' fun) 112 | 113 | -- | Desugar 'x != y' to '!(x == y)'. 114 | desugar_alg (BinaryExpr x tp left BNeq right) = 115 | return $ In $ UnaryExpr x tp UNot $ In $ BinaryExpr x tp left BEq right 116 | 117 | -- | Desugar 'x[i]' to '(*x)[i]' when x is a pointer to an array. 118 | desugar_alg (IndexExpr x tp e ix) = case tp of 119 | PointerType arr_tp@(ArrayType _len _tp) -> 120 | return $ In $ IndexExpr x tp (In $ StarExpr x arr_tp e) ix 121 | _tp -> return $ In $ IndexExpr x tp e ix 122 | 123 | -- | Insert missing return statements and convert variadic to slice. 124 | desugar_alg (FuncDecl x recv name params variadic results 125 | (Just (In (BlockNode body)))) = do 126 | let params' = params ++ case variadic of 127 | Nothing -> [] 128 | Just (In (FieldNode names tp tag)) -> 129 | [In $ FieldNode names 130 | (In $ ArrayTypeExpr x (typeOf' tp) Nothing tp) tag] 131 | return $ In $ FuncDecl x recv name params' Nothing results $ Just $ In $ 132 | BlockNode $ insert_returns x (mkTuple x $ field_names x results) body 133 | 134 | -- | Desugar increment and decrement statements to assign statements. 135 | desugar_alg (IncDecStmt x expr is_incr) = 136 | return $ mkBinopAssign x Assign (if is_incr then BPlus else BMinus) expr $ 137 | In $ BasicConstExpr x (BasicType $ BasicUntyped UntypedInt) $ BasicConstInt 1 138 | 139 | -- | Desugar range statements over slices, arrays, strings, or 140 | -- pointers to arrays to regular 'for' loops with index counter 141 | -- variables. 142 | desugar_alg stmt@(RangeStmt x key value range (In (BlockNode body)) is_assign) = 143 | return $ In $ 144 | if isArrayOrSliceType (typeOf' range) || isStringType (typeOf' range) then 145 | ForStmt x (Just $ ini) (Just $ cond range) (Just post) $ 146 | In $ BlockNode $ body' range 147 | else case typeOf' range of 148 | PointerType arr_tp@(ArrayType _len _tp) -> 149 | let deref = In $ StarExpr x arr_tp range in 150 | ForStmt x (Just $ ini) (Just $ cond deref) Nothing $ 151 | In $ BlockNode $ body' deref 152 | _tp -> stmt 153 | where 154 | assign_op = if is_assign then Assign else Define 155 | -- Generate a fresh variable name. For now we use a fixed 156 | -- identifier that is illegal in Go. Nested 'range' loops will 157 | -- reuse the same variable but it should be fine because it only 158 | -- needs to be in scope for the first two statements of the body 159 | -- that we generate. 160 | ix = In $ IdentExpr x (intType Nothing) Nothing $ Ident IdentVar "?i" 161 | ini = In $ AssignStmt x Define Nothing [ix] [intConst x Nothing 0] 162 | cond e = In $ BinaryExpr x boolType ix BLt $ 163 | In $ CallExpr x (intType Nothing) False 164 | (In $ IdentExpr x NoType Nothing $ Ident IdentFunc "len") 165 | [e] 166 | post = mkBinopAssign x Assign BPlus ix $ intConst x Nothing 1 167 | body' e = 168 | maybe [] (\k -> [In $ AssignStmt x assign_op Nothing [k] [ix]]) key ++ 169 | maybe [] (\v -> [In $ AssignStmt x assign_op Nothing [v] 170 | [In $ IndexExpr x (elementType $ typeOf' e) e ix]]) value ++ body 171 | 172 | -- | Do nothing for all other nodes. 173 | desugar_alg n = return $ In n 174 | 175 | -- | When the input list consists of a single expression of tuple 176 | -- type, generate a list of its projected elements. This is used to 177 | -- allow a tuple value to appear in a context that expects multiple 178 | -- values. 179 | unpack_tuple :: [Node a Expr] -> [Node a Expr] 180 | unpack_tuple [arg] = case typeOf' arg of 181 | -- Elements of 1-tuple type shall be unchanged. 182 | TupleType [_t] -> [arg] 183 | TupleType ts -> 184 | (\(i, t) -> In $ ProjExpr (annotOf' arg) (typeOfNameType t) arg i) 185 | <$> zip [0..] ts 186 | _t -> [arg] 187 | unpack_tuple args = args 188 | 189 | -- | Given a default return expression, ensure that a list of 190 | -- statements terminates with a return statement. 191 | -- TODO: fix naked returns 192 | insert_returns :: a -> Node a Expr -> [Node a Stmt] -> [Node a Stmt] 193 | -- Replace empty body with a return. 194 | insert_returns x e [] = [In $ ReturnStmt x [e]] 195 | -- Fill in empty return. There are two possibilities: 196 | -- 1) our function has no returns so es = [] and this has no effect. 197 | -- 2) our function has named returns and this is "naked return", so we 198 | -- fill in the return identifiers. 199 | -- insert_returns _x e [In (ReturnStmt y [])] = [In $ ReturnStmt y [e]] 200 | insert_returns _x e [In (ReturnStmt y [In (TupleExpr _y _tp [])])] = 201 | [In $ ReturnStmt y [e]] 202 | -- If there's already a nonempty return statement, leave it alone. 203 | insert_returns _x _e stmts@[In (ReturnStmt _ _)] = stmts 204 | -- If the last statement is not a return, insert one after. 205 | insert_returns x e [stmt] = [stmt, In $ ReturnStmt x [e]] 206 | -- Recurse to get to the last statement. 207 | insert_returns x e (stmt:stmts) = stmt : insert_returns x e stmts 208 | 209 | field_names :: a -> [Node a Field] -> [Node a Expr] 210 | field_names x = concatMap $ \(In (FieldNode nms tp _)) -> 211 | (In . IdentExpr x (typeOf' tp) Nothing) <$> nms 212 | 213 | mkTuple :: a -> [Node a Expr] -> Node a Expr 214 | mkTuple x es = In $ TupleExpr x (TupleType $ typeToNameType . typeOf' <$> es) es 215 | 216 | mkBinopAssign :: a -> AssignType -> BinaryOp 217 | -> Node a Expr -> Node a Expr 218 | -> Node a Stmt 219 | mkBinopAssign x assignType binop l r = 220 | In $ AssignStmt x assignType Nothing [l] [In $ BinaryExpr x (typeOf' l) l binop r] 221 | -------------------------------------------------------------------------------- /src/Language/Go/Parser.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Language.Go.Parser 3 | Description : JSON AST deserializer 4 | Maintainer : abagnall@galois.com 5 | Stability : experimental 6 | 7 | Parse JSON-encoded Go ASTs. 8 | -} 9 | {-# LANGUAGE DataKinds #-} 10 | {-# LANGUAGE FlexibleContexts #-} 11 | {-# LANGUAGE FlexibleInstances #-} 12 | {-# LANGUAGE KindSignatures #-} 13 | {-# LANGUAGE OverloadedStrings #-} 14 | {-# LANGUAGE ScopedTypeVariables #-} 15 | {-# LANGUAGE UndecidableInstances #-} 16 | module Language.Go.Parser (parseMain, SourcePos) where 17 | 18 | import Data.Aeson 19 | import Data.ByteString.Lazy (ByteString) 20 | import Data.Text (Text) 21 | 22 | import Language.Go.AST 23 | import Language.Go.Rec 24 | import Language.Go.Types as T 25 | 26 | -- | Entry point. 27 | parseMain :: ByteString -> Either String (Node SourcePos Main) 28 | parseMain txt = eitherDecode txt 29 | 30 | data SourcePos = 31 | SourcePos { pos_filename :: Text 32 | , pos_column :: Int 33 | , pos_line :: Int 34 | , pos_offset :: Int 35 | } 36 | deriving (Eq, Show) 37 | 38 | noPos :: SourcePos 39 | noPos = SourcePos { pos_filename = "" 40 | , pos_column = 0 41 | , pos_line = 0 42 | , pos_offset = 0 43 | } 44 | 45 | -- | Type synonym for a single unfolding of the Node type. It's easier 46 | -- to define FromJSON instances for this and derive the corresponding 47 | -- Node instances automatically. 48 | type N (i :: NodeType) = NodeF SourcePos (Fix (NodeF SourcePos)) i 49 | 50 | instance FromJSON SourcePos where 51 | parseJSON = withObject "SourcePos" $ \v -> SourcePos <$> 52 | v .: "filename" <*> v .: "column" <*> v .: "line" <*> v .: "offset" 53 | 54 | instance FromJSON (N i) => FromJSON (Node SourcePos i) where 55 | parseJSON x = In <$> parseJSON x 56 | 57 | instance FromJSON (N Main) where 58 | parseJSON = withObject "Main" $ \v -> 59 | MainNode <$> v .: "name" <*> v .: "package" <*> v .: "imports" 60 | 61 | instance FromJSON (N Package) where 62 | parseJSON = withObject "Package" $ \v -> 63 | PackageNode <$> v .: "name" <*> v .: "path" <*> 64 | v .: "imports" <*> v .:? "file-paths" .!= [] <*> 65 | v .: "files" <*> v .: "initializers" 66 | 67 | instance FromJSON (N File) where 68 | parseJSON = withObject "File" $ \v -> 69 | FileNode <$> v .: "path" <*> v .: "package-name" 70 | <*> v .: "declarations" <*> v .: "imports" 71 | 72 | instance FromJSON Ident where 73 | parseJSON = withObject "Ident" $ \v -> 74 | Ident <$> v .: "ident-kind" <*> v .: "value" 75 | 76 | instance FromJSON T.IdentKind where 77 | parseJSON = withText "IdentKind" $ \txt -> 78 | case lookup txt [("Builtin", T.IdentBuiltin), ("Const", T.IdentConst), 79 | ("Func", T.IdentFunc), ("Label", T.IdentLabel), 80 | ("Nil", T.IdentNil), ("PkgName", T.IdentPkgName), 81 | ("TypeName", T.IdentTypeName), ("Var", T.IdentVar), 82 | ("NoKind", T.IdentNoKind)] of 83 | Just k -> return k 84 | Nothing -> 85 | fail $ "FromJSON IdentKind: unknown identifer kind " ++ show txt 86 | 87 | instance FromJSON (N Decl) where 88 | parseJSON = withObject "Decl" $ \v -> do 89 | tp <- v .: "type" 90 | pos <- v .: "position" 91 | case tp :: Text of 92 | x | x `elem` ["function", "method"] -> 93 | FuncDecl pos <$> v .:? "receiver" <*> v .: "name" 94 | <*> v .: "params" <*> v .:? "variadic" <*> v .:? "results" .!= [] 95 | <*> v .:? "body" 96 | "type-alias" -> TypeAliasDecl pos <$> v .: "binds" 97 | _ -> GenDecl pos <$> v .: "specs" 98 | 99 | 100 | instance FromJSON (N Bind) where 101 | parseJSON = withObject "Binding" $ \v -> 102 | Binding <$> v .: "name" <*> v .: "value" 103 | 104 | instance FromJSON (N Field) where 105 | parseJSON = withObject "Field" $ \v -> FieldNode <$> 106 | v .:? "names" .!= [] <*> v .: "declared-type" <*> v .:? "tag" 107 | 108 | instance FromJSON BasicLit where 109 | parseJSON = withObject "BasicLit" $ \v -> 110 | BasicLit <$> v .: "type" <*> v .: "value" 111 | 112 | instance FromJSON BasicLitType where 113 | parseJSON = withText "BasicLitType" $ \txt -> 114 | case lookup txt [("BOOL", LiteralBool), ("INT", LiteralInt), 115 | ("FLOAT", LiteralFloat), ("COMPLEX", LiteralComplex), 116 | ("IMAG", LiteralImag), ("CHAR", LiteralChar), 117 | ("STRING", LiteralString)] of 118 | Just tp -> return tp 119 | _ -> 120 | fail $ "FromJSON BasicLitType: unknown basic literal type " ++ show txt 121 | 122 | instance FromJSON BasicConst where 123 | parseJSON = withObject "BasicConst" $ \v -> do 124 | exprType <- v .: "type" 125 | case exprType :: Text of 126 | "BOOL" -> BasicConstBool . readBool <$> v .: "value" 127 | "STRING" -> BasicConstString <$> v .: "value" 128 | "INT" -> BasicConstInt . read <$> v .: "value" 129 | "FLOAT" -> BasicConstFloat <$> v .: "numerator" <*> v .: "denominator" 130 | "COMPLEX" -> BasicConstFloat <$> v .: "real" <*> v .: "imaginary" 131 | _t -> 132 | fail $ "FromJSON BasicConst: unknown constant type: " ++ show exprType 133 | 134 | instance FromJSON ChanDir where 135 | parseJSON = withText "ChanDir" $ \txt -> case txt of 136 | "send" -> return ChanDirSend 137 | "recv" -> return ChanDirRecv 138 | "both" -> return ChanDirBoth 139 | _ -> fail $ "FromJSON ChanDir: unknown channel direction " ++ show txt 140 | 141 | instance FromJSON (N Expr) where 142 | parseJSON = withObject "Expr" $ \v -> do 143 | exprKind <- v .: "kind" 144 | pos <- v .:? "position" .!= noPos 145 | go_tp <- v .:? "go-type" .!= T.NoType 146 | case exprKind :: Text of 147 | "type" -> do 148 | exprType <- v .: "type" 149 | case exprType :: Text of 150 | tp | tp `elem` ["slice", "array"] -> 151 | ArrayTypeExpr pos go_tp <$> v .:? "length" <*> v .: "element" 152 | "pointer" -> PointerTypeExpr pos go_tp <$> v .: "contained" 153 | "interface" -> 154 | InterfaceTypeExpr pos go_tp <$> v .: "methods" <*> v .: "incomplete" 155 | "map" -> MapTypeExpr pos go_tp <$> v .: "key" <*> v .: "value" 156 | "chan" -> ChanTypeExpr pos go_tp <$> v .: "direction" <*> v .: "value" 157 | "struct" -> StructTypeExpr pos go_tp <$> v .: "fields" 158 | "function" -> FuncTypeExpr pos go_tp <$> v .: "params" <*> 159 | v .:? "variadic" <*> v .:? "results" .!= [] 160 | "ellipsis" -> EllipsisExpr pos go_tp <$> v .:? "value" 161 | "identifier" -> 162 | IdentExpr pos go_tp <$> v .:? "qualifier" <*> v .: "value" 163 | _ -> fail $ "FromJSON Expr: unknown expression of kind 'type': " 164 | ++ show exprType 165 | "literal" -> do 166 | exprType <- v .: "type" 167 | case exprType :: Text of 168 | "function" -> FuncLitExpr pos go_tp <$> v .: "params" <*> 169 | v .:? "results" .!= [] <*> v .: "body" 170 | "composite" -> 171 | CompositeLitExpr pos go_tp <$> v .:? "declared" <*> v .: "values" 172 | _ -> BasicLitExpr pos go_tp <$> parseJSON (Object v) 173 | "constant" -> BasicConstExpr pos go_tp <$> v .: "value" 174 | "expression" -> do 175 | exprType <- v .: "type" 176 | case exprType :: Text of 177 | "index" -> IndexExpr pos go_tp <$> v .: "target" <*> v .: "index" 178 | "star" -> StarExpr pos go_tp <$> v .: "target" 179 | "call" -> CallExpr pos go_tp <$> 180 | v .: "ellipsis" <*> v .: "function" <*> v .: "arguments" 181 | "cast" -> CastExpr pos go_tp <$> v .: "target" <*> v .: "coerced-to" 182 | -- Special cases for 'make' and 'new' builtins 183 | "make" -> do 184 | type_arg <- v .: "argument" 185 | rest_args <- v .: "rest" 186 | return $ CallExpr pos go_tp False 187 | (In $ IdentExpr pos (T.makeType $ typeOf' type_arg) Nothing $ 188 | Ident T.IdentFunc "make") $ 189 | type_arg : rest_args 190 | "new" -> do 191 | type_arg <- v .: "argument" 192 | return $ CallExpr pos go_tp False 193 | (In $ IdentExpr pos (T.newType $ typeOf' type_arg) Nothing $ 194 | Ident T.IdentFunc "new") [type_arg] 195 | "paren" -> ParenExpr pos go_tp <$> v .: "target" 196 | "selector" -> 197 | SelectorExpr pos go_tp <$> v .: "target" <*> v .: "field" 198 | "type-assert" -> 199 | TypeAssertExpr pos go_tp <$> v .: "target" <*> v .:? "asserted" 200 | "identifier" -> do 201 | v' <- v .: "value" 202 | mAsIOTA <- v' .:? "type" 203 | 204 | -- Special case for IOTA: whenever the type is "IOTA" 205 | -- the value should be "IOTA" as well. 206 | case mAsIOTA of 207 | Just ("IOTA" :: Text) -> return $ IdentExpr pos go_tp Nothing $ 208 | Ident T.IdentNoKind "IOTA" 209 | _ -> IdentExpr pos go_tp <$> v .:? "qualifier" <*> v .: "value" 210 | "slice" -> 211 | SliceExpr pos go_tp <$> v .: "target" <*> 212 | v .: "low" <*> v .: "high" <*> v .: "max" <*> v .: "three" 213 | "key-value" -> KeyValueExpr pos go_tp <$> v .: "key" <*> v .: "value" 214 | "ellipsis" -> EllipsisExpr pos go_tp <$> v .:? "value" 215 | "binary" -> BinaryExpr pos go_tp <$> 216 | v .: "left" <*> v .: "operator" <*> v .: "right" 217 | "unary" -> UnaryExpr pos go_tp <$> v .: "operator" <*> v .: "target" 218 | _ -> fail $ "FromJSON Expr: unknown expression of kind 'expression': " 219 | ++ show exprType 220 | _ -> fail $ "FromJSON Expr: unknown kind " ++ show exprKind 221 | 222 | instance FromJSON BinaryOp where 223 | parseJSON = withText "BinaryOp" $ \txt -> 224 | case lookup txt [("+", BPlus), ("-", BMinus), ("*", BMult), ("/", BDiv), 225 | ("%", BMod), ("&", BAnd), ("|", BOr), ("^", BXor), 226 | ("<<", BShiftL), (">>", BShiftR), ("&^", BAndNot), 227 | ("&&", BLAnd), ("||", BLOr), ("==", BEq), ("<", BLt), 228 | (">", BGt), ("!=", BNeq), ("<=", BLeq), (">=", BGeq)] of 229 | Just op -> return op 230 | _ -> fail $ "FromJSON BinaryOP: unknown binary operator " ++ show txt 231 | 232 | instance FromJSON UnaryOp where 233 | parseJSON = withText "UnaryOp" $ \txt -> 234 | case lookup txt [("+", UPlus), ("-", UMinus), ("!", UNot), 235 | ("^", UBitwiseNot), ("*", UStar), ("&", UAddress), 236 | ("<-", UArrow)] of 237 | Just op -> return op 238 | _ -> fail $ "FromJSON UnaryOp: unknown unary operator " ++ show txt 239 | 240 | instance FromJSON BranchType where 241 | parseJSON = withText "BranchType" $ \txt -> case txt of 242 | "break" -> return Break 243 | "continue" -> return Continue 244 | "goto" -> return Goto 245 | "fallthrough" -> return Fallthrough 246 | _ -> fail $ "FromJSON BranchType: unknown branch type " ++ show txt 247 | 248 | instance FromJSON (N Block) where 249 | parseJSON o = BlockNode <$> parseJSON o 250 | 251 | instance FromJSON (N Stmt) where 252 | parseJSON = withObject "Stmt" $ \v -> do 253 | stmtType <- v .: "type" 254 | pos <- v .:? "position" .!= noPos 255 | case stmtType :: Text of 256 | "return" -> ReturnStmt pos <$> v .:? "values" .!= [] 257 | "empty" -> return $ EmptyStmt pos 258 | "expression" -> ExprStmt pos <$> v .: "value" 259 | "labeled" -> LabeledStmt pos <$> v .: "label" <*> v .: "statement" 260 | "branch" -> BranchStmt pos <$> v .: "type" <*> v .:? "label" 261 | "range" -> RangeStmt pos <$> v .: "key" <*> v .: "value" <*> 262 | v .: "target" <*> v .: "body" <*> v .: "is-assign" 263 | "declaration" -> DeclStmt pos <$> v .: "target" 264 | "defer" -> DeferStmt pos <$> v .: "target" 265 | "if" -> IfStmt pos <$> v .:? "init" <*> 266 | v .: "condition" <*> v .: "body" <*> v .:? "else" 267 | "block" -> BlockStmt pos <$> v .: "body" 268 | "for" -> ForStmt pos <$> v .:? "init" <*> 269 | v .:? "condition" <*> v .:? "post" <*> v .: "body" 270 | "go" -> GoStmt pos <$> v .: "target" 271 | "send" -> SendStmt pos <$> v .: "channel" <*> v .: "value" 272 | "select" -> SelectStmt pos <$> v .: "body" 273 | "crement" -> do 274 | op <- v .: "operation" 275 | case op :: Text of 276 | "++" -> IncDecStmt pos <$> v .: "target" <*> pure True 277 | "--" -> IncDecStmt pos <$> v .: "target" <*> pure False 278 | _ -> fail $ "FromJSON IncDecStatement: unknown operator " ++ show op 279 | "switch" -> 280 | SwitchStmt pos <$> v .:? "init" <*> v .:? "condition" <*> v .: "body" 281 | "type-switch" -> 282 | TypeSwitchStmt pos <$> v .:? "init" <*> v .: "assign" <*> v .: "body" 283 | "select-clause" -> 284 | CommClauseStmt pos <$> v .:? "statement" <*> v .: "body" 285 | "case-clause" -> CaseClauseStmt pos <$> v .: "expressions" <*> v .: "body" 286 | tp | tp `elem` ["assign", "define", "assign-operator"] -> do 287 | assignType <- v .: "type" 288 | case assignType :: Text of 289 | "assign" -> 290 | AssignStmt pos Assign Nothing <$> v .: "left" <*> v .: "right" 291 | "define" -> 292 | AssignStmt pos Define Nothing <$> v .: "left" <*> v .: "right" 293 | "assign-operator" -> 294 | AssignStmt pos AssignOperator <$> (Just <$> v .: "operator") 295 | <*> v .: "left" <*> v .: "right" 296 | _ -> fail $ "FromJSON AssignStatement: unknown assign type " 297 | ++ show assignType 298 | "initializer" -> 299 | InitializerStmt <$> v .: "vars" <*> ((:[]) <$> v .: "value") 300 | tp | tp `elem` ["break", "continue", "goto", "fallthrough"] -> 301 | BranchStmt pos <$> v .: "type" <*> v .:? "label" 302 | _ -> fail $ "FromJSON Stmt: unknown statement type " ++ show stmtType 303 | 304 | instance FromJSON (N Spec) where 305 | parseJSON = withObject "Spec" $ \v -> do 306 | pos <- v .: "position" 307 | specType <- v .: "type" 308 | case specType :: Text of 309 | "import" -> ImportSpec pos <$> v .:? "name" <*> v .: "path" 310 | "const" -> ConstSpec pos <$> v .: "names" <*> 311 | v .:? "declared-type" <*> v .: "values" 312 | "var" -> VarSpec pos <$> v .: "names" <*> 313 | v .:? "declared-type" <*> v .: "values" 314 | "type" -> TypeSpec pos <$> v .: "name" <*> v .: "value" 315 | _ -> fail $ "FromJSON Spec: unknown spec type " ++ show specType 316 | 317 | instance FromJSON T.BasicKind where 318 | parseJSON = withText "BasicKind" $ \txt -> case lookup txt 319 | [("Invalid", BasicInvalid), ("Bool", BasicBool), 320 | ("Int", BasicInt Nothing), ("Int8", BasicInt $ Just 8), 321 | ("Int16", BasicInt $ Just 16), ("Int32", BasicInt $ Just 32), 322 | ("Int64", BasicInt $ Just 64), ("UInt", BasicUInt Nothing), 323 | ("UInt8", BasicUInt $ Just 8), ("UInt16", BasicUInt $ Just 16), 324 | ("UInt32", BasicUInt $ Just 32), ("UInt64", BasicUInt $ Just 64), 325 | ("UIntptr", BasicUIntptr), ("Float32", BasicFloat 32), 326 | ("Float64", BasicFloat 64), ("Complex64", BasicComplex 64), 327 | ("Complex128", BasicComplex 128), ("String", BasicString), 328 | ("UnsafePointer", BasicUnsafePointer), 329 | ("UntypedBool", BasicUntyped UntypedBool), 330 | ("UntypedInt", BasicUntyped UntypedInt), 331 | ("UntypedRune", BasicUntyped UntypedRune), 332 | ("UntypedFloat", BasicUntyped UntypedFloat), 333 | ("UntypedComplex", BasicUntyped UntypedComplex), 334 | ("UntypedString", BasicUntyped UntypedString), 335 | ("UntypedNil", BasicUntyped UntypedNil)] of 336 | Just k -> return k 337 | _ -> fail $ "FromJSON BasicKind: unknown basic kind " ++ show txt 338 | 339 | instance FromJSON T.NameType where 340 | parseJSON = withObject "NameType" $ \v -> 341 | T.NameType <$> v .: "name" <*> v .: "type" 342 | 343 | instance FromJSON T.Type where 344 | parseJSON = withObject "Type" $ \v -> do 345 | tp <- v .: "type" 346 | case tp :: Text of 347 | "Array" -> T.ArrayType <$> v .: "len" <*> v .: "elem" 348 | "Basic" -> T.BasicType <$> v .: "kind" 349 | "Chan" -> T.ChanType <$> v .: "direction" <*> v .: "elem" 350 | "Interface" -> T.InterfaceType <$> v .: "methods" 351 | "Map" -> T.MapType <$> v .: "key" <*> v .: "elem" 352 | "Named" -> T.NamedType <$> v .: "underlying" 353 | "Pointer" -> T.PointerType <$> v .: "elem" 354 | "Signature" -> do 355 | params <- v .: "params" 356 | -- Desugar 1-tuple result types to the inner type. 357 | result <- v .: "results" >>= \rs -> case rs of 358 | T.TupleType [rt] -> return $ T.typeOfNameType rt 359 | _ -> return rs 360 | case params of 361 | T.TupleType ts -> 362 | T.FuncType <$> v .:? "recv" <*> pure (T.typeOfNameType <$> ts) 363 | <*> pure result <*> v .: "variadic" 364 | _ -> fail $ "FromJSON Type: expected TupleType, got " ++ show params 365 | "Slice" -> T.SliceType <$> v .: "elem" 366 | "Struct" -> T.StructType <$> v .: "fields" 367 | "Tuple" -> T.TupleType <$> v .: "fields" 368 | _ -> fail $ "FromJSON Type: unknown type " ++ show v 369 | -------------------------------------------------------------------------------- /src/Language/Go/Rec.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Language.Go.Rec 3 | Description : Golang recursion schemes 4 | Maintainer : abagnall@galois.com 5 | Stability : experimental 6 | 7 | Recursion scheme combinators for Go abstract syntax. 8 | -} 9 | {-# LANGUAGE DataKinds #-} 10 | {-# LANGUAGE PolyKinds #-} 11 | {-# LANGUAGE RankNTypes #-} 12 | module Language.Go.Rec where 13 | 14 | import Data.Functor.Const 15 | import Data.Functor.Product 16 | 17 | import Data.Parameterized.TraversableFC 18 | 19 | import Language.Go.Types 20 | 21 | newtype Fix f i = In (f (Fix f) i) 22 | 23 | out :: Fix f i -> f (Fix f) i 24 | out (In f) = f 25 | 26 | cata :: FunctorFC f 27 | => (forall i. f a i -> a i) 28 | -> (forall i. Fix f i -> a i) 29 | cata phi = phi . fmapFC (cata phi) . out 30 | 31 | cata' :: FunctorFC f 32 | => (forall i. f (Const a) i -> a) 33 | -> (forall i. Fix f i -> a) 34 | cata' phi = getConst . cata (Const . phi) 35 | 36 | cataM :: (TraversableFC f, Monad m) 37 | => (forall i. f a i -> m (a i)) 38 | -> (forall i. Fix f i -> m (a i)) 39 | cataM phi (In x) = traverseFC (cataM phi) x >>= phi 40 | 41 | cataM' :: (TraversableFC f, Monad m) 42 | => (forall i. f (Const a) i -> m a) 43 | -> (forall i. Fix f i -> m a) 44 | cataM' phi = (getConst <$>) . cataM ((Const <$>) . phi) 45 | 46 | para :: FunctorFC f 47 | => (forall i. f (Product (Fix f) a) i -> a i) 48 | -> (forall i. Fix f i -> a i) 49 | para phi = phi . fmapFC (\x -> Pair x (para phi x)) . out 50 | 51 | paraM :: (TraversableFC f, Monad m) 52 | => (forall i. f (Product (Fix f) a) i -> m (a i)) 53 | -> (forall i. Fix f i -> m (a i)) 54 | paraM phi (In x) = traverseFC (\y -> Pair y <$> paraM phi y) x >>= phi 55 | 56 | ---------------------------------------------------------------------- 57 | -- Utility functions 58 | 59 | pairM :: Applicative f => f a -> f b -> f (a, b) 60 | pairM x y = (,) <$> x <*> y 61 | 62 | proj1 :: forall f g (a :: NodeType). Product f g a -> f a 63 | proj1 (Pair x _y) = x 64 | 65 | proj2 :: forall f g (a :: NodeType). Product f g a -> g a 66 | proj2 (Pair _x y) = y 67 | -------------------------------------------------------------------------------- /src/Language/Go/Rename.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Language.Go.Rename 3 | Description : Golang renamer 4 | Maintainer : abagnall@galois.com 5 | Stability : experimental 6 | 7 | The renamer fills in missing qualifiers for global identifiers so that 8 | every global becomes fully qualified. 9 | -} 10 | {-# LANGUAGE DataKinds #-} 11 | {-# LANGUAGE GADTs #-} 12 | {-# LANGUAGE KindSignatures #-} 13 | {-# LANGUAGE OverloadedStrings #-} 14 | module Language.Go.Rename (rename) where 15 | 16 | import Control.Monad (forM_) 17 | import Control.Monad.Identity (Identity(..)) 18 | import Control.Monad.State (StateT, evalStateT, gets, modify) 19 | 20 | import Data.Default.Class 21 | import Data.Functor.Product 22 | import Data.List (nub) 23 | import Data.Text (Text) 24 | 25 | import Data.Parameterized.TraversableFC 26 | 27 | import Language.Go.AST 28 | import Language.Go.Rec 29 | import Language.Go.Types 30 | 31 | -- | Entry point. 32 | rename :: Show a => Node a tp -> Node a tp 33 | rename = runRM def . para rename_alg 34 | 35 | data RState = 36 | RState { rs_package :: Text -- ^ Name of current package 37 | , rs_locals :: [Text] -- ^ Locals in scope 38 | } 39 | 40 | instance Default RState where 41 | def = RState { rs_package = "INITIAL_RENAMER_PACKAGE_NAME" 42 | , rs_locals = [] } 43 | 44 | -- We could use ReaderT instead and scan blocks for assign statements 45 | -- before entering them. Either way seems reasonable. 46 | type RM' a = StateT RState Identity a 47 | 48 | newtype RM a (tp :: NodeType) = 49 | RM { unRM :: RM' (Node a tp) } 50 | 51 | runRM :: RState -> RM a tp -> Node a tp 52 | runRM st = runIdentity . (`evalStateT` st) . unRM 53 | 54 | -- | Helper for running subterm renamer actions. 55 | run :: Product (Node a) (RM a) tp -> RM' (Node a tp) 56 | run (Pair _node (RM m)) = m 57 | 58 | 59 | -- | The renamer algebra. 60 | rename_alg :: Show a => NodeF a (Product (Node a) (RM a)) tp -> RM a tp 61 | 62 | rename_alg (MainNode nm pkg imports) = RM $ do 63 | imports' <- mapM run imports 64 | modify $ \rs -> rs { rs_package = nm } 65 | pkg' <- run pkg 66 | return $ In $ MainNode nm pkg' imports' 67 | 68 | -- | Store package name in reader state. 69 | rename_alg (PackageNode name path imports file_paths files inits) = RM $ do 70 | modify $ \rs -> rs { rs_package = name } 71 | files' <- mapM run files 72 | inits' <- mapM run inits 73 | return $ In $ PackageNode name path imports file_paths files' inits' 74 | 75 | -- | So far this is the only place where we need access to original 76 | -- nodes so we can register the LHS variables as locals before 77 | -- renaming them (as they would be considered to be globals otherwise 78 | -- and have qualifiers erroneously filled in). 79 | rename_alg (AssignStmt x assign_type op lhs rhs) = RM $ do 80 | case assign_type of 81 | -- Only add variables when the assignment is a "short declaration" 82 | -- statement (':=' syntax). If a variable already exists as a 83 | -- global, it will be shadowed by a new local. 84 | Define -> do 85 | forM_ lhs $ \(Pair node _rm) -> case node of 86 | In (IdentExpr _x _tp _q (Ident _k name)) -> addLocal name 87 | _node -> error "rename_alg AssignStmt: expected ident in LHS" 88 | _ -> return () 89 | In <$> (AssignStmt x assign_type op <$> mapM run lhs <*> mapM run rhs) 90 | 91 | rename_alg (DeclStmt x decl) = RM $ do 92 | decl' <- run decl 93 | case decl' of 94 | In (GenDecl _x specs) -> forM_ specs $ \spec -> case spec of 95 | In (ConstSpec _y names _ty _values) -> forM_ names $ addLocal . identName 96 | In (VarSpec _y names _ty _values) -> forM_ names $ addLocal . identName 97 | _spec -> return () 98 | _decl -> return () 99 | return $ In $ DeclStmt x decl' 100 | 101 | -- | Save and restore locals. 102 | rename_alg (BlockNode stmts) = RM $ local $ In . BlockNode <$> mapM run stmts 103 | 104 | -- | Also need to save and restore the locals around a for loop, even 105 | -- though the body is already a block, because the initialization 106 | -- statement can bind new locals. 107 | rename_alg (ForStmt x ini cond post body) = RM $ 108 | local $ In <$> (ForStmt x <$> mapM run ini <*> mapM run cond <*> 109 | mapM run post <*> run body) 110 | 111 | -- | Same thing for if statements. 112 | rename_alg (IfStmt x ini cond body els) = RM $ 113 | local $ In <$> (IfStmt x <$> mapM run ini <*> run cond <*> 114 | run body <*> mapM run els) 115 | 116 | -- | Same thing for switch statements. 117 | rename_alg (SwitchStmt x ini tag body) = RM $ 118 | local $ In <$> (SwitchStmt x <$> mapM run ini <*> mapM run tag <*> run body) 119 | 120 | -- | Same thing for typeswitch statements. 121 | rename_alg (TypeSwitchStmt x ini stmt body) = RM $ 122 | local $ In <$> (TypeSwitchStmt x <$> mapM run ini <*> run stmt <*> run body) 123 | 124 | -- | Add bindings for params and named returns. 125 | rename_alg (FuncDecl x recv name params variadic results body) = RM $ 126 | local $ do 127 | params' <- mapM run params 128 | results' <- mapM run results 129 | forM_ (field_names $ params' ++ results') addLocal 130 | recv' <- mapM run recv 131 | variadic' <- mapM run variadic -- Should be Nothing if we've run 132 | -- the desugarer 133 | body' <- mapM run body 134 | return $ In $ FuncDecl x recv' name params' variadic' results' body' 135 | 136 | -- | Add bindings for params and named returns 137 | rename_alg (FuncLitExpr x tp params results body) = RM $ 138 | local $ do 139 | params' <- mapM run params 140 | results' <- mapM run results 141 | forM_ (field_names $ params' ++ results') addLocal 142 | body' <- run body 143 | return $ In $ FuncLitExpr x tp params' results' body' 144 | 145 | -- When an unqualified identifier isn't in the local context, set its 146 | -- qualifier to the current package. 147 | rename_alg (IdentExpr x tp Nothing ident@(Ident k name)) = RM $ do 148 | locals <- gets rs_locals 149 | if name `elem` locals then return $ In $ IdentExpr x tp Nothing ident 150 | else do 151 | pkgName <- gets rs_package 152 | return $ In $ IdentExpr x tp (Just (Ident IdentPkgName pkgName)) $ 153 | Ident k name 154 | 155 | -- Do nothing for all other nodes. 156 | rename_alg node = RM $ In <$> traverseFC run node 157 | 158 | 159 | addLocal :: Text -> RM' () 160 | addLocal nm = modify $ \rs -> rs { rs_locals = nub $ nm : rs_locals rs } 161 | 162 | -- | Save and restore the locals around a renamer computation. 163 | local :: RM' a -> RM' a 164 | local m = do 165 | locals <- gets rs_locals 166 | m' <- m 167 | modify $ \rs -> rs { rs_locals = locals } 168 | return m' 169 | 170 | field_names :: [Node a Field] -> [Text] 171 | field_names [] = [] 172 | field_names (In (FieldNode nms _ty _tag) : fields) = 173 | (identName <$> nms) ++ field_names fields 174 | -------------------------------------------------------------------------------- /src/Language/Go/Types.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Language.Go.Types 3 | Description : Golang type semantics 4 | Maintainer : abagnall@galois.com 5 | Stability : experimental 6 | 7 | The definitions here mirror those from the "go/types" package. They 8 | represent semantic type information, not syntactic type expressions as 9 | may appear in the syntax of a program. 10 | -} 11 | {-# LANGUAGE OverloadedStrings #-} 12 | {-# LANGUAGE PolyKinds #-} 13 | module Language.Go.Types where 14 | 15 | import Data.Text 16 | 17 | -- | Type indices for Go AST nodes. 18 | data NodeType = Main | Package | File | Stmt | Expr 19 | | Decl | Field | Spec | Bind | Block 20 | 21 | -- | An identifier. 22 | data Ident = 23 | Ident IdentKind -- ^ The kind of object the identifier denotes 24 | Text -- ^ Identifier text 25 | deriving (Eq, Show) 26 | 27 | identName :: Ident -> Text 28 | identName (Ident _k name) = name 29 | 30 | data IdentKind = 31 | IdentNoKind 32 | | IdentBuiltin 33 | | IdentConst 34 | | IdentFunc 35 | | IdentLabel 36 | | IdentNil 37 | | IdentPkgName 38 | | IdentTypeName 39 | | IdentVar 40 | deriving (Eq, Show) 41 | 42 | data UntypedKind = 43 | UntypedBool 44 | | UntypedInt 45 | | UntypedRune 46 | | UntypedFloat 47 | | UntypedComplex 48 | | UntypedString 49 | | UntypedNil 50 | deriving (Eq, Show) 51 | 52 | data BasicKind = 53 | BasicInvalid 54 | | BasicBool 55 | | BasicInt (Maybe Int) -- ^ 8, 16, 32, 64 56 | | BasicUInt (Maybe Int) -- ^ 8, 16, 32, 64 57 | | BasicUIntptr 58 | | BasicFloat Int -- ^ 32, 64 59 | | BasicComplex Int -- ^ 64, 128 60 | | BasicString 61 | | BasicUnsafePointer 62 | | BasicUntyped UntypedKind 63 | deriving (Eq, Show) 64 | 65 | data ChanDir = 66 | ChanDirSend 67 | | ChanDirRecv 68 | | ChanDirBoth 69 | deriving (Eq, Show) 70 | 71 | data NameType = NameType Text Type 72 | deriving (Eq, Show) 73 | 74 | typeOfNameType :: NameType -> Type 75 | typeOfNameType (NameType _nm tp) = tp 76 | 77 | typeToNameType :: Type -> NameType 78 | typeToNameType tp = NameType "" tp 79 | 80 | data Type = 81 | NoType 82 | | ArrayType Int Type 83 | | BasicType BasicKind 84 | | ChanType ChanDir Type 85 | | InterfaceType [NameType] 86 | | MapType Type Type 87 | | NamedType Type 88 | | PointerType Type 89 | -- | receiver, params, result (always tuple), variadic? 90 | | FuncType (Maybe (Ident, Type)) [Type] Type Bool 91 | | SliceType Type 92 | | StructType [NameType] 93 | | TupleType [NameType] 94 | deriving (Eq, Show) 95 | 96 | isUntyped :: Type -> Bool 97 | isUntyped (BasicType (BasicUntyped _)) = True 98 | isUntyped _ = False 99 | 100 | isArrayOrSliceType :: Type -> Bool 101 | isArrayOrSliceType (ArrayType _len _tp) = True 102 | isArrayOrSliceType (SliceType _tp) = True 103 | isArrayOrSliceType _tp = False 104 | 105 | isStringType :: Type -> Bool 106 | isStringType (BasicType BasicString) = True 107 | isStringType _tp = False 108 | 109 | mkReturnType :: [Type] -> Type 110 | mkReturnType [tp] = tp 111 | mkReturnType tps = TupleType $ typeToNameType <$> tps 112 | 113 | arrayTypeLen :: Type -> Int 114 | arrayTypeLen (ArrayType len _t) = len 115 | arrayTypeLen tp = error $ "arrayTypeLen: expected ArrayType, got" ++ show tp 116 | 117 | elementType :: Type -> Type 118 | elementType (ArrayType _len tp) = tp 119 | elementType (SliceType tp) = tp 120 | -- Special case for pointers to arrays. 121 | elementType (PointerType (ArrayType _len tp)) = tp 122 | elementType (PointerType tp) = tp 123 | elementType (MapType _k tp) = tp 124 | elementType (ChanType _dir tp) = tp 125 | elementType tp = error $ "elementType: invalid type " ++ show tp 126 | 127 | -- | The type of the built-in 'new' function, given the element 128 | -- type. Use empty list for argument types. 129 | newType :: Type -> Type 130 | newType tp = FuncType Nothing [] (PointerType tp) False 131 | 132 | -- | The type of the built-in 'make' function, given the element 133 | -- type. Use empty list for argument types. 134 | makeType :: Type -> Type 135 | makeType tp = FuncType Nothing [] tp False 136 | 137 | boolType :: Type 138 | boolType = BasicType BasicBool 139 | 140 | intType :: Maybe Int -> Type 141 | intType w = BasicType $ BasicInt w 142 | 143 | uintType :: Maybe Int -> Type 144 | uintType w = BasicType $ BasicUInt w 145 | 146 | floatType :: Int -> Type 147 | floatType w = BasicType $ BasicFloat w 148 | 149 | complexType :: Int -> Type 150 | complexType w = BasicType $ BasicComplex w 151 | 152 | stringType :: Type 153 | stringType = BasicType BasicString 154 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # http://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-7.16 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - '.' 40 | - location: 41 | git: https://github.com/GaloisInc/anastasia 42 | commit: 6087ab3f994497fabcb69b94c4563f1ac84b6699 43 | # Dependency packages to be pulled from upstream that are not in the resolver 44 | # (e.g., acme-missiles-0.3) 45 | extra-deps: [alex-tools-0.1.1.0, anastasia-0.1.0.0] 46 | 47 | # Override default flag values for local packages and extra-deps 48 | flags: {} 49 | 50 | # Extra package databases containing global packages 51 | extra-package-dbs: [] 52 | 53 | # Control whether we use the GHC we find on the path 54 | # system-ghc: true 55 | # 56 | # Require a specific version of stack, using version ranges 57 | # require-stack-version: -any # Default 58 | # require-stack-version: ">=1.2" 59 | # 60 | # Override the architecture used by stack, especially useful on Windows 61 | # arch: i386 62 | # arch: x86_64 63 | # 64 | # Extra directories used by stack for building 65 | # extra-include-dirs: [/path/to/dir] 66 | # extra-lib-dirs: [/path/to/dir] 67 | # 68 | # Allow a newer minor version of GHC than the snapshot specifies 69 | # compiler-check: newer-minor 70 | --------------------------------------------------------------------------------